diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index cdacb620b0..e5af9feb36 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -32,6 +32,7 @@ setup: - 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) @@ -73,7 +74,7 @@ gnu:ice-ocean-nolibs: - 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_ocean_extras,land_null,atmos_null} + - ../../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) @@ -115,8 +116,8 @@ run: - 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 "make -f MRS/Makefile.tests all -B" > job.sh - - msub -l partition=c4,nodes=29,walltime=00:31:00,qos=norm -q debug -S /bin/tcsh -j oe -A gfdl_o -z -o log.$CI_PIPELINE_ID -N mom6_regression -K job.sh + - (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 diff --git a/.testing/Makefile b/.testing/Makefile new file mode 100644 index 0000000000..ee561375a3 --- /dev/null +++ b/.testing/Makefile @@ -0,0 +1,77 @@ +# Makefile steps to run on Travis-CI +# e.g. make MEMORY_SHAPE=dynamic_symmetric REPRO=1 OPENMP=1 + +# Versions to use +FMS_COMMIT ?= xanadu +MKMF_COMMIT ?= master + +# Where to clone from +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 + +# Experiments to run +ifeq ($(MEMORY_SHAPE),"dynamic_symmetric") +EXPERIMENTS ?= unit_tests double_gyre flow_downslope/z CVmix_SCM_tests/cooling_only/EPBL circle_obcs +else +EXPERIMENTS ?= unit_tests double_gyre flow_downslope/z CVmix_SCM_tests/cooling_only/EPBL +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 + +# Everything above is above is "configurable" with environment variables +SHELL = bash + +# 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 + +.PRECIOUS: %/ocean.stats + +run: $(foreach e,$(EXPERIMENTS),$(EXPERIMENTS_ROOT)/ocean_only/$(e)/ocean.stats) + +test: $(foreach e,$(EXPERIMENTS),$(REGRESSIONS_ROOT)/regressions/ocean_only/$(e)/ocean.stats.gnu) + +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) + +$(EXPERIMENTS_ROOT)/%/ocean.stats: $(EXPERIMENTS_ROOT) + mkdir -p $(@D)/RESTART + cd $(@D) ; $(MPIRUN) -n 1 $(PWD)/$(BUILD_PATH)/MOM6 + +$(REGRESSIONS_ROOT)/regressions/%/ocean.stats.gnu: $(EXPERIMENTS_ROOT)/%/ocean.stats $(REGRESSIONS_ROOT) + cp $< $@ + cd $(@D) ; git status --porcelain $(@F) + +# 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) + +$(EXPERIMENTS_ROOT): + mkdir -p $(@D) + cd $(@D) ; git clone --depth 1 $(CONFIGS_URL) experiments + +$(REGRESSIONS_ROOT): + mkdir -p $(@D) + cd $(@D) ; git clone --depth 1 $(REGRESSIONS_URL) answers diff --git a/.testing/README.md b/.testing/README.md new file mode 100644 index 0000000000..46b154da14 --- /dev/null +++ b/.testing/README.md @@ -0,0 +1,3 @@ +# .testing + +This directory contains scripts used when evaluating commits on Travis-CI diff --git a/.testing/configure b/.testing/configure new file mode 100755 index 0000000000..841635d6f4 --- /dev/null +++ b/.testing/configure @@ -0,0 +1,4 @@ +#!/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 new file mode 100644 index 0000000000..80abc4e48d --- /dev/null +++ b/.testing/linux-ubuntu-xenial-gnu.mk @@ -0,0 +1,273 @@ +# 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/trailer.py b/.testing/trailer.py new file mode 100755 index 0000000000..80b7e72738 --- /dev/null +++ b/.testing/trailer.py @@ -0,0 +1,95 @@ +#!/usr/bin/env python + +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. + """ + + # 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 + + main(args) + +def main(args): + ''' + Does 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) + fail = fail or this + if fail: sys.exit(1) + +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() diff --git a/.travis.yml b/.travis.yml index f211d9f162..5c5c31a6a4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,47 +3,109 @@ # This is a not a c-language project but we use the same environment. language: c -dist: trusty -sudo: false +dist: xenial addons: apt: sources: - ubuntu-toolchain-r-test packages: - - tcsh pkg-config netcdf-bin libnetcdf-dev openmpi-bin libopenmpi-dev gfortran + - 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 -# For saving time... cache: directories: - - MOM6-examples -# - build # Uncomment this line to save time building. Less robust when FMS changes version! - -# Install tools and clone the configurations repository -before_install: - - git clone https://github.com/adcroft/house_cleaning.git - # This line clones MOM6-examples when there is no cache - - test -f MOM6-examples/README.md || (rm -rf MOM6-examples && git clone https://github.com/NOAA-GFDL/MOM6-examples.git) + - 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: - # This restores all files in MOM6-examples and updates - - (cd MOM6-examples/ && git checkout . && git pull) - # Update submodules mkmf and FMS - - (cd MOM6-examples/src/ && git submodule init mkmf FMS && git submodule update mkmf FMS) + - echo "Install step" + - cp .testing/{configure,Makefile} . -# Build FMS before_script: - - bash MOM6-examples/tools/tests/Travis-MOM6/build_fms.sh - - bash MOM6-examples/tools/tests/Travis-MOM6/before_script.sh - -# Tests to run -script: - - ./house_cleaning/trailer.py -e TEOS10 src config_src - - bash MOM6-examples/tools/tests/Travis-MOM6/build_ocean_only.sh - - bash MOM6-examples/tools/tests/Travis-MOM6/build_symmetric_ocean_only.sh - - bash MOM6-examples/tools/tests/Travis-MOM6/run_tests.sh + - ls -l + - ls build +# This avoids caching files we do not need between stages before_cache: -- rm -rf build/ocn build/symocn -- (cd MOM6-examples; rm -rf ocean_only; git checkout .) -- find MOM6-examples -type l -exec rm {} \; + - 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 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/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 09d7da3119..5112a0b64b 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -1177,12 +1177,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) 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 \n"//& + "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 \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, & @@ -1190,64 +1190,64 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) 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 \n"//& - "atmosphere and floating sea-ice or ice shelves. This is \n"//& - "needed because the FMS coupling structure does not \n"//& - "limit the water that can be frozen out of the ocean and \n"//& - "the ice-ocean heat fluxes are treated explicitly. No \n"//& + "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, "RESTORE_SALINITY", CS%restore_salt, & - "If true, the coupled driver will add a globally-balanced \n"//& - "fresh-water flux that drives sea-surface salinity \n"//& + "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", CS%restore_temp, & - "If true, the coupled driver will add a \n"//& - "heat flux that drives sea-surface temperauture \n"//& + "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, "ADJUST_NET_SRESTORE_TO_ZERO", & CS%adjust_net_srestore_to_zero, & - "If true, adjusts the salinity restoring seen to zero\n"//& + "If true, adjusts the salinity restoring seen to zero "//& "whether restoring is via a salt flux or virtual precip.",& default=CS%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\n"//& + "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 \n"//& + "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\n"//& + "If true, use the wrong sign for the adjustment to "//& "the net fresh-water.", default=.true.) 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\n"//& + "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 \n"//& + "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 \n"//& - "correction for the atmospheric (and sea-ice) pressure \n"//& - "limited by max_p_surf instead of the full atmospheric \n"//& + "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, "APPROX_NET_MASS_SRC", CS%approx_net_mass_src, & - "If true, use the net mass sources from the ice-ocean \n"//& - "boundary type without any further adjustments to drive \n"//& - "the ocean dynamics. The actual net mass source may differ \n"//& + "If true, use the net mass sources from the ice-ocean "//& + "boundary type without any further adjustments to drive "//& + "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 \n"//& - "staggering of the input wind stress field. Valid \n"//& + "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 @@ -1255,14 +1255,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) 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\n"//& - "coupler. This is used for testing and should be =1.0 for any\n"//& + "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 (CS%restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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, & @@ -1276,19 +1276,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) 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 \n"//& + "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\n"//& + "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\n"//& + "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'.", & @@ -1303,14 +1303,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) enddo ; enddo endif call get_param(param_file, mdl, "MASK_SRESTORE", CS%mask_srestore, & - "If true, read a file (salt_restore_mask) containing \n"//& + "If true, read a file (salt_restore_mask) containing "//& "a mask for SSS restoring.", default=.false.) endif if (CS%restore_temp) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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, & @@ -1327,7 +1327,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "The maximum sst difference used in restoring terms.", & units="degC ", default=999.0) call get_param(param_file, mdl, "MASK_TRESTORE", CS%mask_trestore, & - "If true, read a file (temp_restore_mask) containing \n"//& + "If true, read a file (temp_restore_mask) containing "//& "a mask for SST restoring.", default=.false.) endif @@ -1340,11 +1340,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "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 \n"//& + "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 \n"//& + "The path to the file containing the spatially varying "//& "tidal amplitudes with INT_TIDE_DISSIPATION.", & default="tideamp.nc") CS%utide=0.0 @@ -1379,14 +1379,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) ! constant. call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from \n"//& + "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 \n"//& + "The file in which the wind gustiness is found in "//& "variable gustiness.") call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) @@ -1396,31 +1396,31 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) ! 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 \n"//& + "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, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & - "A typical density of sea ice, used with the kinematic \n"//& + "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 \n"//& + "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 \n"//& + "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\n"//& + "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 \n"//& + "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) diff --git a/config_src/coupled_driver/coupler_util.F90 b/config_src/coupled_driver/coupler_util.F90 deleted file mode 100644 index 2c72c56cce..0000000000 --- a/config_src/coupled_driver/coupler_util.F90 +++ /dev/null @@ -1,137 +0,0 @@ -!> Provides a couple of interfaces to allow more transparent and -!! robust extraction of the various fields in the coupler types. -module coupler_util - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use coupler_types_mod, only : coupler_2d_bc_type, ind_flux, ind_alpha -use coupler_types_mod, only : ind_csurf - -implicit none ; private - -public :: extract_coupler_values, set_coupler_values -public :: ind_flux, ind_alpha, ind_csurf - -contains - -!> Extract an array of values in a coupler bc type -subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, & - is, ie, js, je, conversion) - 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. - real, dimension(:,:), intent(out) :: array_out !< The array being filled with the input values. - integer, optional, intent(in) :: is !< Start i-index - integer, optional, intent(in) :: ie !< End i-index - integer, optional, intent(in) :: js !< Start j-index - integer, optional, intent(in) :: je !< End j-index - real, optional, intent(in) :: conversion !< A number that every element is multiplied by, to - !! permit sign convention or unit conversion. - ! Local variables - real, pointer, dimension(:,:) :: Array_in - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_in => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_out,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_out,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_out,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_out,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_in,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - if (size(Array_in,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - i_offset = lbound(Array_in,1) - is0 - j_offset = lbound(Array_in,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - array_out(i,j) = conv * Array_in(i+i_offset,j+j_offset) - enddo ; enddo - -end subroutine extract_coupler_values - -!> Set an array of values in a coupler bc type -subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, & - is, ie, js, je, conversion) - real, dimension(:,:), 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 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. - !! This could be ind_csurf, ind_alpha, ind_flux or ind_deposition. - integer, optional, intent(in) :: is !< Start i-index - integer, optional, intent(in) :: ie !< End i-index - integer, optional, intent(in) :: js !< Start j-index - integer, optional, intent(in) :: je !< End j-index - real, optional, intent(in) :: conversion !< A number that every element is multiplied by, to - !! permit sign convention or unit conversion. - ! Local variables - real, pointer, dimension(:,:) :: Array_out - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_out => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_in,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_in,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_in,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_in,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_out,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - if (size(Array_out,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - i_offset = lbound(Array_out,1) - is0 - j_offset = lbound(Array_out,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - Array_out(i+i_offset,j+j_offset) = conv * array_in(i,j) - enddo ; enddo - -end subroutine set_coupler_values - -end module coupler_util diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 5af0b774b0..f9b84a97e1 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -278,41 +278,41 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) 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 \n"//& - "including both dynamics and thermodynamics. If false, \n"//& + "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 \n"//& - "is actually used will be an integer fraction of the \n"//& + "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.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & - "The thermodynamic and tracer advection time step. \n"//& - "Ideally DT_THERM should be an integer multiple of DT \n"//& - "and less than the forcing or coupling time-step, unless \n"//& - "THERMO_SPANS_COUPLING is true, in which case DT_THERM \n"//& - "can be an integer multiple of the coupling timestep. By \n"//& + "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) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & - "If true, the MOM will take thermodynamic and tracer \n"//& - "timesteps that can be longer than the coupling timestep. \n"//& - "The actual thermodynamic timestep that is used in this \n"//& - "case is the largest integer multiple of the coupling \n"//& + "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, \n"//& - "including buoyancy forcing and mass gain or loss, \n"//& + "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 \n"//& - "written. Add 2 (bit 1) for a time-stamped file, and odd \n"//& - "(bit 0) for a non-time-stamped file. A restart file \n"//& - "will be saved at the end of the run segment for any \n"//& + "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 \n"//& - "staggering of the surface velocity field that is \n"//& - "returned to the coupler. Valid values include \n"//& + "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 @@ -321,9 +321,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) trim(stagger)//" is invalid.") ; endif call get_param(param_file, mdl, "RHO_0", Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, & @@ -341,9 +341,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) ! 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 \n"//& - "over which melt potential is computed will be min(HFREEZE, OBLD), \n"//& - "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), \n"//& + "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 @@ -442,8 +442,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda real, optional, intent(in) :: cycle_length !< The duration of a coupled time stepping cycle [s]. ! Local variables - type(time_type) :: Time_seg_start ! Stores the ocean model time at the start of this call to allow - ! step_MOM to temporarily change the time as seen by internal modules. + type(time_type) :: Time_seg_start ! Stores the dynamic or thermodynamic ocean model time at the + ! start of this call to allow step_MOM to temporarily change the time + ! as seen by internal modules. + type(time_type) :: Time_thermo_start ! Stores the ocean model thermodynamics time at the start of + ! this call to allow step_MOM to temporarily change the time as 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 of the current fluxes. @@ -563,6 +567,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) endif + Time_thermo_start = OS%Time Time_seg_start = OS%Time ; if (do_dyn) Time_seg_start = OS%Time_dyn Time1 = Time_seg_start @@ -576,7 +581,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda 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 + else ! Step both the dynamics and thermodynamics with separate calls. 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)) @@ -636,7 +641,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (do_dyn) OS%Time_dyn = Time_seg_start + Ocean_coupling_time_step if (do_dyn) OS%nstep = OS%nstep + 1 - OS%Time = Time_seg_start ! Reset the clock to compensate for shared pointers. + OS%Time = Time_thermo_start ! Reset the clock to compensate for shared pointers. if (do_thermo) OS%Time = OS%Time + Ocean_coupling_time_step if (do_thermo) OS%nstep_thermo = OS%nstep_thermo + 1 diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index aec37b2a4a..77099b2595 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -976,7 +976,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! 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 \n"//& + "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.", & @@ -984,33 +984,33 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is \n"//& - "true. This assumes that KD = KDML = 0.0 and that \n"//& - "there is no buoyancy forcing, but makes the model \n"//& + "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 \n"//& + "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 \n"//& - "is specified. Valid options include (file), (zero), \n"//& + "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 \n"//& + "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 \n"//& + "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 \n"//& + "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 \n"//& + "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.", & @@ -1019,28 +1019,28 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "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 \n"//& + "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 \n"//& + "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, \n"//& + "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 \n"//& + "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 \n"//& + "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 \n"//& - "is specified. Valid options include (file), (2gyre), \n"//& + "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 \n"//& + "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.", & @@ -1049,7 +1049,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "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 \n"//& + "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, & @@ -1058,66 +1058,66 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C 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 \n"//& - "zonal wind stress profile: \n"//& + "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 \n"//& - "zonal wind stress profile: \n"//& + "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 \n"//& - "the zonal wind stress profile: \n"//& + "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 \n"//& - "the zonal wind stress profile: \n"//& + "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 \n"//& + "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 \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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 \n"//& - "toward some specified surface state with a rate \n"//& + "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 \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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 \n"//& - "at the northern end of the domain toward which to \n"//& + "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 \n"//& - "at the southern end of the domain toward which to \n"//& + "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 \n"//& - "at the northern end of the domain toward which to \n"//& + "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 \n"//& - "at the southern end of the domain toward which to \n"//& + "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 @@ -1129,11 +1129,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "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 \n"//& + "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 \n"//& + "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) diff --git a/config_src/ice_solo_driver/coupler_types.F90 b/config_src/ice_solo_driver/coupler_types.F90 deleted file mode 100644 index 99a74e085c..0000000000 --- a/config_src/ice_solo_driver/coupler_types.F90 +++ /dev/null @@ -1,3294 +0,0 @@ -module coupler_types_mod - -! This file is part of MOM6. See LICENSE.md for the license. - -! This module contains the coupler-type declarations and methods for use in -! ocean-only configurations of MOM6. It is intended that the version of -! coupler_types_mod that is avialable from FMS will conform to this version with -! the FMS city release after warsaw. - -use fms_io_mod, only: restart_file_type, register_restart_field -use fms_io_mod, only: query_initialized, restore_state -use time_manager_mod, only: time_type -use diag_manager_mod, only: register_diag_field, send_data -use data_override_mod, only: data_override -use mpp_domains_mod, only: domain2D, mpp_redistribute -use mpp_mod, only: stdout, mpp_error, FATAL, mpp_chksum - -implicit none ; private - -public coupler_type_copy, coupler_type_spawn, coupler_type_set_diags -public coupler_type_write_chksums, coupler_type_send_data, coupler_type_data_override -public coupler_type_register_restarts, coupler_type_restore_state -public coupler_type_increment_data, coupler_type_rescale_data -public coupler_type_copy_data, coupler_type_redistribute_data -public coupler_type_destructor, coupler_type_initialized -public coupler_type_extract_data, coupler_type_set_data - -public coupler_type_copy_1d_2d -public coupler_type_copy_1d_3d - -! -! 3-d fields -! -type, public :: coupler_3d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_3d_values_type - -type, public :: coupler_3d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_3d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_3d_field_type - -type, public :: coupler_3d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type - integer :: ks, ke !< The k-direction index ranges for this type -end type coupler_3d_bc_type - -! -! 2-d fields -! -type, public :: coupler_2d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_2d_values_type - -type, public :: coupler_2d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_2d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_2d_field_type - -type, public :: coupler_2d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type -end type coupler_2d_bc_type - -! -! 1-d fields -! -type, public :: coupler_1d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, dimension(:) :: values => NULL() !< The pointer to the array of values - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_1d_values_type - -type, public :: coupler_1d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_1d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_1d_field_type - -type, public :: coupler_1d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized -end type coupler_1d_bc_type - -!---------------------------------------------------------------------- -! The following public parameters can help in selecting the sub-elements of a -! coupler type. There are duplicate values because different boundary -! conditions have different sub-elements. -integer, parameter, public :: ind_pcair = 1 !< The index of the atmospheric concentration -integer, parameter, public :: ind_u10 = 2 !< The index of the 10 m wind speed -integer, parameter, public :: ind_psurf = 3 !< The index of the surface atmospheric pressure -integer, parameter, public :: ind_alpha = 1 !< The index of the solubility array for a tracer -integer, parameter, public :: ind_csurf = 2 !< The index of the ocean surface concentration -integer, parameter, public :: ind_sc_no = 3 !< The index for the Schmidt number for a tracer flux -integer, parameter, public :: ind_flux = 1 !< The index for the tracer flux -integer, parameter, public :: ind_deltap= 2 !< The index for ocean-air gas partial pressure change -integer, parameter, public :: ind_kw = 3 !< The index for the piston velocity -integer, parameter, public :: ind_deposition = 1 !< The index for the atmospheric deposition flux -integer, parameter, public :: ind_runoff = 1 !< The index for a runoff flux - -!---------------------------------------------------------------------- -! Interface definitions for overloaded routines -!---------------------------------------------------------------------- - -!> This is the interface to spawn one coupler_bc_type into another and then -!! register diagnostics associated with the new type. -interface coupler_type_copy - module procedure coupler_type_copy_1d_2d, coupler_type_copy_1d_3d - module procedure coupler_type_copy_2d_2d, coupler_type_copy_2d_3d - module procedure coupler_type_copy_3d_2d, coupler_type_copy_3d_3d -end interface coupler_type_copy - -!> This is the interface to spawn one coupler_bc_type into another. -interface coupler_type_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d, CT_spawn_3d_2d - module procedure CT_spawn_1d_3d, CT_spawn_2d_3d, CT_spawn_3d_3d -end interface coupler_type_spawn - -!> This is the interface to copy the field data from one coupler_bc_type -!! to another of the same rank, size and decomposition. -interface coupler_type_copy_data - module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d -end interface coupler_type_copy_data - -!> This is the interface to redistribute the field data from one coupler_bc_type -!! to another of the same rank and global size, but a different decomposition. -interface coupler_type_redistribute_data - module procedure CT_redistribute_data_2d, CT_redistribute_data_3d -end interface coupler_type_redistribute_data - -!> This is the interface to rescale the field data in a coupler_bc_type. -interface coupler_type_rescale_data - module procedure CT_rescale_data_2d, CT_rescale_data_3d -end interface coupler_type_rescale_data - -!> This is the interface to increment the field data from one coupler_bc_type -!! with the data from another. Both must have the same horizontal size and -!! decomposition, but a 2d type may be incremented by a 2d or 3d type -interface coupler_type_increment_data - module procedure CT_increment_data_2d_2d, CT_increment_data_3d_3d, CT_increment_data_2d_3d -end interface coupler_type_increment_data - -!> This is the interface to extract a field in a coupler_bc_type into an array. -interface coupler_type_extract_data - module procedure CT_extract_data_2d, CT_extract_data_3d, CT_extract_data_3d_2d -end interface coupler_type_extract_data - -!> This is the interface to set a field in a coupler_bc_type from an array. -interface coupler_type_set_data - module procedure CT_set_data_2d, CT_set_data_3d, CT_set_data_2d_3d -end interface coupler_type_set_data - -!> This is the interface to set diagnostics for the arrays in a coupler_bc_type. -interface coupler_type_set_diags - module procedure CT_set_diags_2d, CT_set_diags_3d -end interface coupler_type_set_diags - -!> This is the interface to write out checksums for the elements of a coupler_bc_type. -interface coupler_type_write_chksums - module procedure CT_write_chksums_2d, CT_write_chksums_3d -end interface coupler_type_write_chksums - -!> This is the interface to write out diagnostics of the arrays in a coupler_bc_type. -interface coupler_type_send_data - module procedure CT_send_data_2d, CT_send_data_3d -end interface coupler_type_send_data - -!> This is the interface to override the values of the arrays in a coupler_bc_type. -interface coupler_type_data_override - module procedure CT_data_override_2d, CT_data_override_3d -end interface coupler_type_data_override - -!> This is the interface to register the fields in a coupler_bc_type to be saved -!! in restart files. -interface coupler_type_register_restarts - module procedure CT_register_restarts_2d, CT_register_restarts_3d - module procedure CT_register_restarts_to_file_2d, CT_register_restarts_to_file_3d -end interface coupler_type_register_restarts - -!> This is the interface to read in the fields in a coupler_bc_type that have -!! been saved in restart files. -interface coupler_type_restore_state - module procedure CT_restore_state_2d, CT_restore_state_3d -end interface coupler_type_restore_state - -!> This function interface indicates whether a coupler_bc_type has been initialized. -interface coupler_type_initialized - module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d -end interface coupler_type_initialized - -!> This is the interface to deallocate any data associated with a coupler_bc_type. -interface coupler_type_destructor - module procedure CT_destructor_1d, CT_destructor_2d, CT_destructor_3d -end interface coupler_type_destructor - -contains - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 1-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_1d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_1d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_1d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 1-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_1d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_1d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_1d_3d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 2-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_2d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_2d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_2d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 2-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_2d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_2d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_2d_3d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 3-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_3d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_3d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_3d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 3-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_3d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_3d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_3d_3d - - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 1-D to 2-D version for generic coupler_type_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var_out, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_1d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_1d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 1-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_1d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_1d_3d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 2-D to 2-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_2d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_2d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 2-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_2d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_2d_3d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 3-D to 2-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_3d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_3d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 3-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_3d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_3d_3d - - -!> This subroutine does a direct copy of the data in all elements of one -!! 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 - logical :: copy_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_2d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_2d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_2d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_2d - -!> This subroutine does a direct copy of the data in all elements of one -!! coupler_3d_bc_type into another. Both types 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 - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is a k-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc ; k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_3d - -!> This subroutine does a direct copy of the data in all elements of a -!! coupler_2d_bc_type into a coupler_3d_bc_type. Both types must have the same -!! array sizes for their 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. - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, ks, ke - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the output structure.") - endif - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var_in%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var_in%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var_in%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - ks = var%ks ; if (present(ind3_start)) ks = max(ks, ind3_start) - ke = var%ke ; if (present(ind3_end)) ke = max(ke, ind3_end) - do k=ks,ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_2d_3d - - -!> This subroutine redistributes 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 (intent in) - 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 - - real, pointer, dimension(:,:) :: null_ptr2D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. ; if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 ; fc_out = 0 - if (do_in) then ; do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo ; enddo ; endif - if (fc_in == 0) do_in = .false. - if (do_out) then ; do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo ; enddo ; endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL, & - "Mismatch in num_bcs in CT_copy_data_2d.") - if (fc_in /= fc_out) call mpp_error(FATAL, & - "Mismatch in the total number of fields in CT_redistribute_data_2d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv. & - associated(var_out%bc(n)%field(m)%values) ) & - call mpp_error(FATAL, & - "Mismatch in which fields are associated in CT_redistribute_data_2d.") - - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_in) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, null_ptr2D, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_out) then - do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr2D, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo ; enddo - endif - -end subroutine CT_redistribute_data_2d - -!> This subroutine redistributes 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_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 (intent in) - 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 - - real, pointer, dimension(:,:,:) :: null_ptr3D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. ; if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 ; fc_out = 0 - if (do_in) then ; do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo ; enddo ; endif - if (fc_in == 0) do_in = .false. - if (do_out) then ; do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo ; enddo ; endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL, & - "Mismatch in num_bcs in CT_copy_data_3d.") - if (fc_in /= fc_out) call mpp_error(FATAL, & - "Mismatch in the total number of fields in CT_redistribute_data_3d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv. & - associated(var_out%bc(n)%field(m)%values) ) & - call mpp_error(FATAL, & - "Mismatch in which fields are associated in CT_redistribute_data_3d.") - - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_in) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, null_ptr3D, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_out) then - do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr3D, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo ; enddo - endif - -end subroutine CT_redistribute_data_3d - - -!> This subroutine 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, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - 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 - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or - !! the full arrays if scale is 0. - 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 - logical :: do_bc - integer :: i, j, m, n, n1, n2, halo - - if (present(bc_index)) then - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.") - if (present(field_index)) then ; if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_2d: Excessive i-direction halo size.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_2d: Excessive j-direction halo size.") - endif - - do n = n1, n2 - - do_bc = .true. - if (do_bc .and. present(exclude_flux_type)) & - do_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (do_bc .and. present(only_flux_type)) & - do_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (do_bc .and. present(pass_through_ice)) & - do_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.do_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - if (scale == 0.0) then - if (present(halo_size)) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = 0.0 - enddo ; enddo - else - var%bc(n)%field(m)%values(:,:) = 0.0 - endif - else - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = scale * var%bc(n)%field(m)%values(i,j) - enddo ; enddo - endif - endif - enddo - enddo - -end subroutine CT_rescale_data_2d - -!> This subroutine 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, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - 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 - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or - !! the full arrays if scale is 0. - 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 - logical :: do_bc - integer :: i, j, k, m, n, n1, n2, halo - - if (present(bc_index)) then - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.") - if (present(field_index)) then ; if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_3d: Excessive i-direction halo size.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_3d: Excessive j-direction halo size.") - endif - - do n = n1, n2 - - do_bc = .true. - if (do_bc .and. present(exclude_flux_type)) & - do_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (do_bc .and. present(only_flux_type)) & - do_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (do_bc .and. present(pass_through_ice)) & - do_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.do_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - if (scale == 0.0) then - if (present(halo_size)) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = 0.0 - enddo ; enddo ; enddo - else - var%bc(n)%field(m)%values(:,:,:) = 0.0 - endif - else - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = scale * var%bc(n)%field(m)%values(i,j,k) - enddo ; enddo ; enddo - endif - endif - enddo - enddo - -end subroutine CT_rescale_data_3d - - -!> This subroutine does a direct increment of the data in all elements of one -!! coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, 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 add to the other type - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 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 - 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. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_2d_2d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_2d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_2d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = sc_prev * var%bc(n)%field(m)%values(i,j) + & - scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_2d_2d - - -!> This subroutine does a direct increment of the data in all elements of one -!! coupler_3d_bc_type into another. Both must have the same array sizes. -subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, 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 add to the other type - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - 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 - 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. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_3d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is a k-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc ; k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = sc_prev * var%bc(n)%field(m)%values(i,j,k) + & - scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_3d_3d - -!> This subroutine does increments the data in the elements of a coupler_2d_bc_type -!! with the weighed average of the elements of a coupler_3d_bc_type. Both must have -!! the same horizontal array sizes and the normalized weight array must match the -!! array sizes of the coupler_3d_bc_type. -subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, 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 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 BC_type structure whose fields are being incremented - 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 - 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. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, k, m, n, n1, n2, halo - integer :: io1, jo1, iow, jow, kow ! Offsets to account for different index conventions. - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_2d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is a j-direction computional domain size mismatch.") - if ((1+var_in%ke-var_in%ks) /= size(weights,3)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is a k-direction size mismatch with the weights array.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive j-direction halo size for the output structure.") - - if ((1+var%iec-var%isc) == size(weights,1)) then - iow = 1 - var%isc - elseif ((1+var%ied-var%isd) == size(weights,1)) then - iow = 1 - var%isd - elseif ((1+var_in%ied-var_in%isd) == size(weights,1)) then - iow = 1 + (var_in%isc - var_in%isd) - var%isc - else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size "//& - "of a computational or data domain.") - endif - if ((1+var%jec-var%jsc) == size(weights,2)) then - jow = 1 - var%jsc - elseif ((1+var%jed-var%jsd) == size(weights,2)) then - jow = 1 - var%jsd - elseif ((1+var_in%jed-var_in%jsd) == size(weights,2)) then - jow = 1 + (var_in%jsc - var_in%jsd) - var%jsc - else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size "//& - "of a computational or data domain.") - endif - - io1 = var_in%isc - var%isc ; jo1 = var_in%jsc - var%jsc ; kow = 1 - var_in%ks - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var_in%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var_in%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var_in%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var_in%ks,var_in%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = sc_prev * var%bc(n)%field(m)%values(i,j) + & - (scale * weights(i+iow,j+jow,k+kow)) * var_in%bc(n)%field(m)%values(i+io1,j+io1,k) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_2d_3d - - -!> This subroutine extracts a single 2-d field from a coupler_2d_bc_type into -!! a two-dimensional array. -subroutine CT_extract_data_2d(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 - 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j) - enddo ; enddo - -end subroutine CT_extract_data_2d - -!> This subroutine extracts a single k-level of a 3-d field from a coupler_3d_bc_type -!! into a two-dimensional array. -subroutine CT_extract_data_3d_2d(var_in, bc_index, field_index, k_in, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_3d_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 - integer, intent(in) :: k_in !< The k-index to extract - 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_3d_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if ((k_in > var_in%ke) .or. (k_in < var_in%ks)) then - write (error_msg, *) trim(error_header), ' The extracted k-index of ', k_in, & - ' is outside of the valid range of ', var_in%ks, ' to ', var_in%ke - call mpp_error(FATAL, trim(error_msg)) - endif - - do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k_in) - enddo ; enddo - -end subroutine CT_extract_data_3d_2d - -!> This subroutine extracts a single 3-d field from a coupler_3d_bc_type into -!! a three-dimensional array. -subroutine CT_extract_data_3d(var_in, bc_index, field_index, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_3d_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 - real, dimension(1:,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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_3d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off, k_off - - if (bc_index <= 0) then - array_out(:,:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if (size(array_out,3) /= 1 + var_in%ke - var_in%ks) then - write (error_msg, *) trim(error_header), ' The target array with k-dimension size ', & - size(array_out,3), ' does not match the data of size ', & - (1 + var_in%ke - var_in%ks) - call mpp_error(FATAL, trim(error_msg)) - endif - k_off = 1 - var_in%ks - - do k=var_in%ks,var_in%ke ; do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off,k+k_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k) - enddo ; enddo ; enddo - -end subroutine CT_extract_data_3d - - -!> This subroutine sets a single 2-d field in a coupler_3d_bc_type from -!! a two-dimensional array. -subroutine CT_set_data_2d(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 copied - 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j) = scale * array_in(i+i_off,j+j_off) - enddo ; enddo - -end subroutine CT_set_data_2d - -!> This subroutine sets a one k-level of a single 3-d field in a -!! coupler_3d_bc_type from a two-dimensional array. -subroutine CT_set_data_2d_3d(array_in, bc_index, field_index, k_out, 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 copied - integer, intent(in) :: k_out !< The k-index to set - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_3d_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - if ((k_out > var%ke) .or. (k_out < var%ks)) then - write (error_msg, *) trim(error_header), ' The seted k-index of ', k_out, & - ' is outside of the valid range of ', var%ks, ' to ', var%ke - call mpp_error(FATAL, trim(error_msg)) - endif - - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j,k_out) = scale * array_in(i+i_off,j+j_off) - enddo ; enddo - -end subroutine CT_set_data_2d_3d - -!> This subroutine sets a single 3-d field in a coupler_3d_bc_type from -!! a three-dimensional array. -subroutine CT_set_data_3d(array_in, bc_index, field_index, var, & - scale_factor, halo_size, idim, jdim) - real, dimension(1:,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 copied - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_3d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off, k_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - if (size(array_in,3) /= 1 + var%ke - var%ks) then - write (error_msg, *) trim(error_header), ' The target array with k-dimension size ', & - size(array_in,3), ' does not match the data of size ', & - (1 + var%ke - var%ks) - call mpp_error(FATAL, trim(error_msg)) - endif - k_off = 1 - var%ks - - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j,k) = scale * array_in(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - -end subroutine CT_set_data_3d - - -!> This routine registers the diagnostics of a coupler_2d_bc_type. -subroutine CT_set_diags_2d(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--if blank, - !! then don't 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 - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 2) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - '(coupler_types_set_diags_3d): axes has less than 2 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name, & - var%bc(n)%field(m)%name, axes(1:2), Time, & - var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units ) - enddo - enddo - -end subroutine CT_set_diags_2d - -!> This routine registers the diagnostics of a coupler_3d_bc_type. -subroutine CT_set_diags_3d(var, diag_name, axes, time) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 3) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - '(coupler_types_set_diags_3d): axes has less than 3 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name, & - var%bc(n)%field(m)%name, axes(1:3), Time, & - var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units ) - enddo - enddo - -end subroutine CT_set_diags_3d - - -!> This subroutine writes out all diagnostics of elements of a coupler_2d_bc_type -subroutine CT_send_data_2d(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 - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_send_data_2d - -!> This subroutine writes out all diagnostics of elements of a coupler_2d_bc_type -subroutine CT_send_data_3d(var, Time) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_send_data_3d - - -!> This subroutine registers the fields in a coupler_2d_bc_type to be saved -!! in restart files specified in the field table. -subroutine CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m - - ocn_rest = .true. ; if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = register_restart_field(bc_rest_files(f), & - rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_2d - -!> This subroutine registers the fields in a coupler_2d_bc_type to be saved -!! in the specified restart file. -subroutine CT_register_restarts_to_file_2d(var, file_name, rest_file, mpp_domain, & - varname_prefix) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = register_restart_field(rest_file, & - file_name, var_name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_to_file_2d - -!> This subroutine registers the fields in a coupler_3d_bc_type to be saved -!! in restart files specified in the field table. -subroutine CT_register_restarts_3d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m, id_restart - - ocn_rest = .true. ; if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = register_restart_field(bc_rest_files(f), & - rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_3d - -!> This subroutine registers the fields in a coupler_3d_bc_type to be saved -!! in the specified restart file. -subroutine CT_register_restarts_to_file_3d(var, file_name, rest_file, mpp_domain, & - varname_prefix) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = register_restart_field(rest_file, & - file_name, var_name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_to_file_3d - - -!> This subroutine reads in the fields in a coupler_2d_bc_type that have -!! been saved in restart files. -subroutine CT_restore_state_2d(var, directory, all_or_nothing, & - all_required, test_by_field) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. ; all_set = .true. ; num_fld = 0 ; unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. ; all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest, & - directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL, & - "CT_restore_state_2d: test_by_field is true, and "//& - trim(unset_varname)//" was not read but some other fields in "//& - trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL, & - "CT_restore_state_2d: all_or_nothing is true, and "//& - trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then ; if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_2d: all_required is true, but "//& - trim(unset_varname)//" was not read from its restart file.") - endif ; endif - -end subroutine CT_restore_state_2d - -!> This subroutine reads in the fields in a coupler_3d_bc_type that have -!! been saved in restart files. -subroutine CT_restore_state_3d(var, directory, all_or_nothing, & - all_required, test_by_field) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. ; all_set = .true. ; num_fld = 0 ; unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. ; all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest, & - directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL, & - "CT_restore_state_3d: test_by_field is true, and "//& - trim(unset_varname)//" was not read but some other fields in "//& - trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL, & - "CT_restore_state_3d: all_or_nothing is true, and "//& - trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then ; if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_3d: all_required is true, but "//& - trim(unset_varname)//" was not read from its restart file.") - endif ; endif - -end subroutine CT_restore_state_3d - - -!> This subroutine potentially overrides the values in a coupler_2d_bc_type -subroutine CT_data_override_2d(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 - - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_data_override_2d - -!> This subroutine potentially overrides the values in a coupler_3d_bc_type -subroutine CT_data_override_3d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_data_override_3d - - -!> This subroutine writes 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 - - character(len=120) :: var_name - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') trim(var_name), & - mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec) ) - enddo ; enddo - -end subroutine CT_write_chksums_2d - -!> This subroutine writes 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 - - character(len=120) :: var_name - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') var_name, & - mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec,:) ) - enddo ; enddo - -end subroutine CT_write_chksums_3d - - -!> This function indicates whether a coupler_1d_bc_type has been initialized. -function CT_initialized_1d(var) - type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_1d !< The return value, indicating whether this type has been initialized - - CT_initialized_1d = var%set -end function CT_initialized_1d - -!> This function indicates whether a coupler_2d_bc_type has been initialized. -function CT_initialized_2d(var) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_2d !< The return value, indicating whether this type has been initialized - - CT_initialized_2d = var%set -end function CT_initialized_2d - -!> This function indicates whether a coupler_3d_bc_type has been initialized. -function CT_initialized_3d(var) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_3d !< The return value, indicating whether this type has been initialized - - CT_initialized_3d = var%set -end function CT_initialized_3d - - -!> This subroutine deallocates 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 - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_1d - -!> This subroutine deallocates 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 - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_2d - - -!> This subroutine deallocates all data associated with a coupler_3d_bc_type -subroutine CT_destructor_3d(var) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_3d - -end module coupler_types_mod diff --git a/config_src/ice_solo_driver/coupler_util.F90 b/config_src/ice_solo_driver/coupler_util.F90 deleted file mode 100644 index dde67c2976..0000000000 --- a/config_src/ice_solo_driver/coupler_util.F90 +++ /dev/null @@ -1,144 +0,0 @@ -module coupler_util - -! This file is part of MOM6. See LICENSE.md for the license. - -! This code provides a couple of interfaces to allow more transparent and -! robust extraction of the various fields in the coupler types. -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use coupler_types_mod, only : coupler_2d_bc_type, ind_flux, ind_alpha -use coupler_types_mod, only : ind_csurf - -implicit none ; private - -public :: extract_coupler_values, set_coupler_values -public :: ind_flux, ind_alpha, ind_csurf - -contains - -subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, & - is, ie, js, je, conversion) - type(coupler_2d_bc_type), intent(in) :: BC_struc - integer, intent(in) :: BC_index, BC_element - real, dimension(:,:), intent(out) :: array_out - integer, optional, intent(in) :: is, ie, js, je - real, optional, intent(in) :: conversion -! Arguments: BC_struc - The type from which the data is being extracted. -! (in) BC_index - The boundary condition number being extracted. -! (in) BC_element - The element of the boundary condition being extracted. -! This could be ind_csurf, ind_alpha, ind_flux or ind_deposition. -! (out) array_out - The array being filled with the input values. -! (in, opt) is, ie, js, je - The i- and j- limits of array_out to be filled. -! These must match the size of the corresponding value array or an -! error message is issued. -! (in, opt) conversion - A number that every element is multiplied by, to -! permit sign convention or unit conversion. - - real, pointer, dimension(:,:) :: Array_in - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_in => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_out,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_out,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_out,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_out,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_in,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - if (size(Array_in,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - i_offset = lbound(Array_in,1) - is0 - j_offset = lbound(Array_in,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - array_out(i,j) = conv * Array_in(i+i_offset,j+j_offset) - enddo ; enddo - -end subroutine extract_coupler_values - -subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, & - is, ie, js, je, conversion) - real, dimension(:,:), intent(in) :: array_in - type(coupler_2d_bc_type), intent(inout) :: BC_struc - integer, intent(in) :: BC_index, BC_element - integer, optional, intent(in) :: is, ie, js, je - real, optional, intent(in) :: conversion -! Arguments: array_in - The array containing the values to load into the BC. -! (out) BC_struc - The type into which the data is being loaded. -! (in) BC_index - The boundary condition number being extracted. -! (in) BC_element - The element of the boundary condition being extracted. -! This could be ind_csurf, ind_alpha, ind_flux or ind_deposition. -! (in, opt) is, ie, js, je - The i- and j- limits of array_out to be filled. -! These must match the size of the corresponding value array or an -! error message is issued. -! (in, opt) conversion - A number that every element is multiplied by, to -! permit sign convention or unit conversion. - - real, pointer, dimension(:,:) :: Array_out - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_out => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_in,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_in,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_in,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_in,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_out,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - if (size(Array_out,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - i_offset = lbound(Array_out,1) - is0 - j_offset = lbound(Array_out,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - Array_out(i+i_offset,j+j_offset) = conv * array_in(i,j) - enddo ; enddo - -end subroutine set_coupler_values - -end module coupler_util diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index 7bfc7ec5ad..1d6f46427d 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -209,14 +209,14 @@ program SHELF_main 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 \n"//& + "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 \n"//& + "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics.", & units="s", fail_if_missing=.true.) @@ -250,16 +250,16 @@ program SHELF_main 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 \n"//& - "TIMEUNIT seconds. This also sets the potential end \n"//& - "time of the present run segment if the end time is \n"//& + "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 \n"//& - "TIMEUNIT seconds. This also sets the potential end \n"//& - "time of the present run segment if the end time is \n"//& + "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 @@ -271,14 +271,14 @@ program SHELF_main "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 \n"//& - "written. Add 2 (bit 1) for a time-stamped file, and odd \n"//& - "(bit 0) for a non-time-stamped file. A non-time-stamped \n"//& - "restart file is saved at the end of the run segment \n"//& + "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 \n"//& - "of TIMEUNIT. Use 0 (the default) to not save \n"//& + "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) diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 33c66a3c40..2d899ce1bb 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -306,16 +306,16 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "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) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, & @@ -323,13 +323,13 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "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 \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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. diff --git a/config_src/mct_driver/MOM_ocean_model.F90 b/config_src/mct_driver/MOM_ocean_model.F90 index 64ef660dbf..8bb3346021 100644 --- a/config_src/mct_driver/MOM_ocean_model.F90 +++ b/config_src/mct_driver/MOM_ocean_model.F90 @@ -286,15 +286,15 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! 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 \n"//& - "written. Add 2 (bit 1) for a time-stamped file, and odd \n"//& - "(bit 0) for a non-time-stamped file. A restart file \n"//& - "will be saved at the end of the run segment for any \n"//& + "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 \n"//& - "staggering of the surface velocity field that is \n"//& - "returned to the coupler. Valid values include \n"//& + "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 @@ -308,17 +308,17 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i end if call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & - "If true, the coupled driver will add a globally-balanced \n"//& - "fresh-water flux that drives sea-surface salinity \n"//& + "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 \n"//& - "heat flux that drives sea-surface temperauture \n"//& + "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 \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, & @@ -339,8 +339,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i 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 \n"//& - "below berg are set to zero. Not applied for negative \n"//& + "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 @@ -350,9 +350,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! vertical integrals, since the related 3-d sums are not negligible in cost. call get_param(param_file, mdl, "HFREEZE", HFrz, & - "If HFREEZE > 0, melt potential will be computed. The actual depth \n"//& - "over which melt potential is computed will be min(HFREEZE, OBLD), \n"//& - "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), \n"//& + "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 diff --git a/config_src/mct_driver/MOM_surface_forcing.F90 b/config_src/mct_driver/MOM_surface_forcing.F90 index fc9e7b7eeb..5b17cbbcff 100644 --- a/config_src/mct_driver/MOM_surface_forcing.F90 +++ b/config_src/mct_driver/MOM_surface_forcing.F90 @@ -1033,12 +1033,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, 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 \n"//& + "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 \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, & @@ -1046,46 +1046,46 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, 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 \n"//& - "atmosphere and floating sea-ice or ice shelves. This is \n"//& - "needed because the FMS coupling structure does not \n"//& - "limit the water that can be frozen out of the ocean and \n"//& - "the ice-ocean heat fluxes are treated explicitly. No \n"//& + "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\n"//& + "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\n"//& + "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 \n"//& + "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\n"//& + "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\n"//& + "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 \n"//& + "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 \n"//& - "correction for the atmospheric (and sea-ice) pressure \n"//& - "limited by max_p_surf instead of the full atmospheric \n"//& + "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. @@ -1094,8 +1094,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, 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 \n"//& - "staggering of the input wind stress field. Valid \n"//& + "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 @@ -1103,14 +1103,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, 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\n"//& - "coupler. This is used for testing and should be =1.0 for any\n"//& + "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 \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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, & @@ -1124,19 +1124,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, 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 \n"//& + "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\n"//& + "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\n"//& + "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'.", & @@ -1154,8 +1154,8 @@ 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 \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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, & @@ -1182,11 +1182,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "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 \n"//& + "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 \n"//& + "The path to the file containing the spatially varying "//& "tidal amplitudes with INT_TIDE_DISSIPATION.", & default="tideamp.nc") CS%utide=0.0 @@ -1221,14 +1221,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, ! constant. call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from \n"//& + "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 \n"//& + "The file in which the wind gustiness is found in "//& "variable gustiness.") call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) @@ -1239,31 +1239,31 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, ! 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 \n"//& + "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, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & - "A typical density of sea ice, used with the kinematic \n"//& + "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 \n"//& + "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 \n"//& + "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\n"//& + "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 \n"//& + "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) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 5ce89fc9f7..5698335b6f 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -259,19 +259,19 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) if (glb%sw_decomp) then call get_param(param_file, mdl, "SW_c1", glb%c1, & - "Coeff. used to convert net shortwave rad. into \n"//& + "Coeff. used to convert net shortwave rad. into "//& "visible, direct shortwave.", units="nondim", default=0.285) call get_param(param_file, mdl, "SW_c2", glb%c2, & - "Coeff. used to convert net shortwave rad. into \n"//& + "Coeff. used to convert net shortwave rad. into "//& "visible, diffuse shortwave.", units="nondim", default=0.285) call get_param(param_file, mdl, "SW_c3", glb%c3, & - "Coeff. used to convert net shortwave rad. into \n"//& + "Coeff. used to convert net shortwave rad. into "//& "near-IR, direct shortwave.", units="nondim", default=0.215) call get_param(param_file, mdl, "SW_c4", glb%c4, & - "Coeff. used to convert net shortwave rad. into \n"//& + "Coeff. used to convert net shortwave rad. into "//& "near-IR, diffuse shortwave.", units="nondim", default=0.215) else glb%c1 = 0.0; glb%c2 = 0.0; glb%c3 = 0.0; glb%c4 = 0.0 diff --git a/config_src/nuopc_driver/MOM_ocean_model.F90 b/config_src/nuopc_driver/MOM_ocean_model.F90 new file mode 100644 index 0000000000..abe583ffcc --- /dev/null +++ b/config_src/nuopc_driver/MOM_ocean_model.F90 @@ -0,0 +1,1178 @@ +!> Top-level module for the MOM6 ocean model in coupled mode. +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. +! +! 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_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 + +#include + +#ifdef _USE_GENERIC_TRACER +use MOM_generic_tracer, only : MOM_generic_tracer_fluxes_accumulate +#endif + +implicit none ; private + +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 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 + + +!> 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 ; private + ! 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 (seconds) + real :: dt_therm !< thermodynamics time step (seconds) + 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), pointer :: & + MOM_CSp => NULL() !< A pointer to the 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 !< A structure containing pointers to the surface wave fields + 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 + +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 + type(time_type) :: dt_geometric, dt_savedays, dt_from_base + + call callTree_enter("ocean_model_init(), ocean_model_MOM.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%C_p, & + use_temp=use_temperature) + OS%fluxes%C_p = OS%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, "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", 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) + 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, 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.) + 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 + + 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) + + endif + + call close_param_file(param_file) + call diag_mediator_close_registration(OS%diag) + + if (is_root_pe()) & + write(*,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + + 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 in seconds. + 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. + 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(), ocean_model_MOM.F90") + call get_time(Ocean_coupling_time_step, secs, days) + dt_coupling = 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 + if (do_thermo) & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & + 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%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, & + 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, skip_pres=.true.) + +#ifdef _USE_GENERIC_TRACER + call enable_averaging(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) + + 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) + 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, & + 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) + ! 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) + + 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, 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, 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) + !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + + 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((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(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) + + 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 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_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 + 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 + 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, write_restart) + 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. + logical, intent(in) :: write_restart !< true => write restart file + + 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) +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_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 + +!> 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, 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 + 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(sfc_state%SSS(i+i0,j+j0), & + 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 + 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)) + 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) + 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) + 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) + enddo ; enddo + endif + + if (associated(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) + 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) + 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) + 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) * & + 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) * & + 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) * & + 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) * & + 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) + 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) + +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 + +!> 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 +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%') +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 diff --git a/config_src/nuopc_driver/MOM_surface_forcing.F90 b/config_src/nuopc_driver/MOM_surface_forcing.F90 new file mode 100644 index 0000000000..8348088b8a --- /dev/null +++ b/config_src/nuopc_driver/MOM_surface_forcing.F90 @@ -0,0 +1,1395 @@ +!> Converts the input ESMF data (import data) to a MOM-specific data type (surface_forcing_CS). +module MOM_surface_forcing + +! This file is part of MOM6. See LICENSE.md for the license. + +!### use MOM_controlled_forcing, only : apply_ctrl_forcing, register_ctrl_forcing_restarts +!### use MOM_controlled_forcing, only : controlled_forcing_init, controlled_forcing_end +!### use MOM_controlled_forcing, only : ctrl_forcing_CS +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 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 + +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 [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, + !! in 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 [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] + 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 :: Kv_sea_ice !! viscosity in sea-ice that resists sheared vertical motions [m^2/s] + 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] + 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 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 + 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. + + ! Diagnostics handles + type(forcing_diags), public :: handles + +!### type(ctrl_forcing_CS), pointer :: ctrl_forcing_CSp => NULL() + 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(:,:) :: 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(:,:) :: 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_water =>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(:,:) :: 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] + 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 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, 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. + 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 varibles + 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, 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 + 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) + + 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 + + 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) + 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) + + fluxes%dt_buoy_accum = 0.0 + 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/)) + + + 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) + 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)*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) + 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%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) + 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%trestore_mask(i,j) * & + (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + enddo ; enddo + 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) = IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%fprec)) & + fluxes%fprec(i,j) = IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%q_flux)) & + fluxes%evap(i,j) = 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) + else if (associated(IOB%runoff)) then + fluxes%lrunoff(i,j) = 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) + else if (associated(IOB%calving)) then + fluxes%frunoff(i,j) = 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 * 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) + + 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%calving_hflx)) & + fluxes%heat_content_frunoff(i,j) = IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%lw_flux)) & + fluxes%LW(i,j) = IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%t_flux)) & + fluxes%sens(i,j) = IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) + + ! ! 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_water(i-i0,j-j0) + + 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 + 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 + 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 + 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) + + enddo ; enddo + + ! 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. + 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) ) + enddo ; enddo + endif + + !### if (associated(CS%ctrl_forcing_CSp)) then + !### do j=js,je ; do i=is,ie + !### SST_anom(i,j) = sfc_state%SST(i,j) - CS%T_Restore(i,j) + !### SSS_anom(i,j) = sfc_state%SSS(i,j) - CS%S_Restore(i,j) + !### SSS_mean(i,j) = 0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j)) + !### enddo ; enddo + !### call apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, fluxes%heat_restore, & + !### fluxes%vprec, day, dt, G, CS%ctrl_forcing_CSp) + !### 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) = (((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) + ! net_FW(i,j) = netFW(i,j) + fluxes%seaice_melt(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) + 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 (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, 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 [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%G_Earth (s^2/m) + 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) + + 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 = 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(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 + + ! 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) * 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(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. + + 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 + 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) = 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) + + 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, 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) & + 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 * 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) + + 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 * 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, halo=1) + + 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 * sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) + else + forces%ustar(i,j) = US%m_to_Z * sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) + endif + enddo ; enddo + + endif ! endif for wind related fields + + ! 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 / G%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 + +!> 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, 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), 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) + 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) + 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) + 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, 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 + +!> 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) + 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. + + ! Local variables + real :: utide ! The RMS tidal velocity, in 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 = "MOM_surface_forcing" ! 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) + 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=.true.) + 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.", 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 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.", 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) + 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) + 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) + 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 MOM_read_data(gust_file,'gustiness',CS%gust,G%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, "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) + 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%id_trestore = 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 register_ctrl_forcing_restarts(G, param_file, CS%ctrl_forcing_CSp, & +!### CS%restart_CSp) + 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 controlled_forcing_init(Time, G, param_file, diag, CS%ctrl_forcing_CSp) + + 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) + +!### call controlled_forcing_end(CS%ctrl_forcing_CSp) + + 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 :: 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_water' , mpp_chksum( iobt%seaice_melt_water) + 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 ) +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/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 new file mode 100644 index 0000000000..24e60388b4 --- /dev/null +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -0,0 +1,2455 @@ +!> +!! @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 | | +!! 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 + +! 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)' +!-------------------------------- + + 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 + call set_calendar_type (JULIAN) + 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% 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%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, "seaice_melt_water" , "will provide") + !call fld_list_add(fldsToOcn_num, fldsToOcn, "seaice_melt_heat" , "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 + 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 = esmf2fms_time(currTime) + Time_step_coupled = esmf2fms_time(timeStep) + + !--------------- + ! 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: ") + call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_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 (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 new file mode 100644 index 0000000000..d893685aec --- /dev/null +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -0,0 +1,866 @@ +!> 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 + !---- + 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) + ! !---- + ! call state_getimport(importState, 'seaice_melt_heat', & + ! 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) + ! !---- + ! call state_getimport(importState, 'seaice_melt_water', & + ! isc, iec, jsc, jec, ice_ocean_boundary%seaice_melt_water,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 + + ! Use Adcroft's rule of reciprocals; it does the right thing here. + 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 + + 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 new file mode 100644 index 0000000000..3f36a131f9 --- /dev/null +++ b/config_src/nuopc_driver/mom_cap_time.F90 @@ -0,0 +1,408 @@ +!> 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 new file mode 100644 index 0000000000..51b8a85c26 --- /dev/null +++ b/config_src/nuopc_driver/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/nuopc_driver/time_utils.F90 new file mode 100644 index 0000000000..e995c1b697 --- /dev/null +++ b/config_src/nuopc_driver/time_utils.F90 @@ -0,0 +1,169 @@ +!> Set of time utilities for converting between FMS and ESMF time type. +module time_utils_mod + +! FMS +use fms_mod, only: uppercase +use mpp_mod, only: mpp_error, FATAL +use time_manager_mod, only: time_type, set_time, set_date, get_date +use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR +use time_manager_mod, only: fms_get_calendar_type => get_calendar_type +! ESMF +use ESMF, only: ESMF_CALKIND_FLAG, ESMF_CALKIND_GREGORIAN +use ESMF, only: ESMF_CALKIND_JULIAN, ESMF_CALKIND_NOLEAP +use ESMF, only: ESMF_CALKIND_360DAY, ESMF_CALKIND_NOCALENDAR +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 + +implicit none; private + +!> Converts calendar from FMS to ESMF format +interface fms2esmf_cal + module procedure fms2esmf_cal_c + module procedure fms2esmf_cal_i +end interface fms2esmf_cal + +!> Converts time from FMS to ESMF format +interface esmf2fms_time + module procedure esmf2fms_time_t + module procedure esmf2fms_timestep +end interface esmf2fms_time + +public fms2esmf_cal +public esmf2fms_time +public fms2esmf_time +public string_to_date + +contains + +!> Sets fms2esmf_cal_c to the corresponding ESMF calendar type +function fms2esmf_cal_c(calendar) + type(ESMF_CALKIND_FLAG) :: fms2esmf_cal_c !< ESMF calendar type + character(len=*), intent(in) :: calendar !< Type of calendar + + select case( uppercase(trim(calendar)) ) + case( 'GREGORIAN' ) + fms2esmf_cal_c = ESMF_CALKIND_GREGORIAN + case( 'JULIAN' ) + fms2esmf_cal_c = ESMF_CALKIND_JULIAN + case( 'NOLEAP' ) + fms2esmf_cal_c = ESMF_CALKIND_NOLEAP + case( 'THIRTY_DAY' ) + fms2esmf_cal_c = ESMF_CALKIND_360DAY + case( 'NO_CALENDAR' ) + fms2esmf_cal_c = ESMF_CALKIND_NOCALENDAR + case default + call mpp_error(FATAL, & + 'ocean_solo: ocean_solo_nml entry calendar must be one of GREGORIAN|JULIAN|NOLEAP|THIRTY_DAY|NO_CALENDAR.' ) + end select +end function fms2esmf_cal_c + +!> Sets fms2esmf_cal_i to the corresponding ESMF calendar type +function fms2esmf_cal_i(calendar) + type(ESMF_CALKIND_FLAG) :: fms2esmf_cal_i !< ESMF calendar structure + integer, intent(in) :: calendar !< Type of calendar + + select case(calendar) + case(THIRTY_DAY_MONTHS) + fms2esmf_cal_i = ESMF_CALKIND_360DAY + case(GREGORIAN) + fms2esmf_cal_i = ESMF_CALKIND_GREGORIAN + case(JULIAN) + fms2esmf_cal_i = ESMF_CALKIND_JULIAN + case(NOLEAP) + fms2esmf_cal_i = ESMF_CALKIND_NOLEAP + case(NO_CALENDAR) + fms2esmf_cal_i = ESMF_CALKIND_NOCALENDAR + end select +end function fms2esmf_cal_i + +!> Converts date from ESMF format to FMS format. +function esmf2fms_time_t(time) + type(Time_type) :: esmf2fms_time_t !< FMS time structure + type(ESMF_Time), intent(in) :: time !< ESMF time structure + + ! Local Variables + integer :: yy, mm, dd, h, m, s + type(ESMF_CALKIND_FLAG) :: calkind + + integer :: rc + + 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 + + esmf2fms_time_t = set_date(yy, mm, dd, h, m, s) + +end function esmf2fms_time_t + +!> Converts time-interval from ESMF format to FMS format. +function esmf2fms_timestep(timestep) + type(Time_type) :: esmf2fms_timestep !< FMS time structure + type(ESMF_TimeInterval), intent(in):: timestep !< time-interval following + !! ESMF format [s] + ! Local Variables + integer :: s + type(ESMF_CALKIND_FLAG) :: calkind + + 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 + + esmf2fms_timestep = set_time(s, 0) + +end function esmf2fms_timestep + +!> Converts date from FMS format to ESMF format. +function fms2esmf_time(time, calkind) + type(ESMF_Time) :: fms2esmf_time !< ESMF time structure + type(time_type), intent(in) :: time !< FMS time structure + type(ESMF_CALKIND_FLAG), intent(in), optional :: calkind !< ESMF calendar structure + + ! Local Variables + integer :: yy, mm, d, h, m, s + type(ESMF_CALKIND_FLAG) :: l_calkind + + integer :: rc + + if(present(calkind)) then + l_calkind = calkind + else + l_calkind = fms2esmf_cal(fms_get_calendar_type()) + endif + + call get_date(time, yy, mm, d, h, m, s) + + 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 + +end function fms2esmf_time + +!> Converts a string (I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2) that represents +!! yr, mon, day, hr, min, sec to a FMS data format. +function string_to_date(string, rc) + character(len=15), intent(in) :: string !< String representing a date + integer, intent(out), optional :: rc !< ESMF error handler + type(time_type) :: string_to_date!< FMS time structure + + ! Local variables + integer :: yr,mon,day,hr,min,sec + + if(present(rc)) rc = ESMF_SUCCESS + + read(string, '(I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2)') yr, mon, day, hr, min, sec + string_to_date = set_date(yr, mon, day, hr, min, sec) + +end function string_to_date + +end module time_utils_mod diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index 28dc5305f1..1ce96fdac2 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -228,16 +228,16 @@ subroutine MESO_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "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) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, & @@ -245,33 +245,33 @@ subroutine MESO_surface_forcing_init(Time, G, param_file, diag, CS) default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "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 \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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 call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in \n"//& + "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 \n"//& + "The file with the surface salinity toward which to "//& "restore in variable SALT.", fail_if_missing=.true.) call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%heating_file, & - "The file with the non-shortwave heat flux in \n"//& + "The file with the non-shortwave heat flux in "//& "variable Heat.", fail_if_missing=.true.) call get_param(param_file, mdl, "PRECIP_FILE", CS%PmE_file, & - "The file with the net precipiation minus evaporation \n"//& + "The file with the net precipiation minus evaporation "//& "in variable PmE.", fail_if_missing=.true.) call get_param(param_file, mdl, "SHORTWAVE_FILE", CS%Solar_file, & - "The file with the shortwave heat flux in \n"//& + "The file with the shortwave heat flux in "//& "variable NET_SOL.", fail_if_missing=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") CS%inputdir = slasher(CS%inputdir) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 14890af0f8..22a216cb80 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -350,8 +350,8 @@ program MOM_main 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_FORCING", dt_forcing, & - "The time step for changing forcing, coupling with other \n"//& - "components, or potentially writing certain diagnostics. \n"//& + "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) if (offline_tracer_mode) then call get_param(param_file, mod_name, "DT_OFFLINE", dt_forcing, & @@ -375,35 +375,35 @@ program MOM_main call get_param(param_file, mod_name, "DAYMAX", daymax, timeunit=Time_unit, & default=Time_end, do_not_log=.true.) call log_param(param_file, mod_name, "DAYMAX", daymax, & - "The final time of the whole simulation, in units of \n"//& - "TIMEUNIT seconds. This also sets the potential end \n"//& - "time of the present run segment if the end time is \n"//& + "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) else call get_param(param_file, mod_name, "DAYMAX", daymax, & - "The final time of the whole simulation, in units of \n"//& - "TIMEUNIT seconds. This also sets the potential end \n"//& - "time of the present run segment if the end time is \n"//& + "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 get_param(param_file, mod_name, "SINGLE_STEPPING_CALL", single_step_call, & - "If true, advance the state of MOM with a single step \n"//& - "including both dynamics and thermodynamics. If false \n"//& + "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, mod_name, "DT_THERM", dt_therm, & - "The thermodynamic and tracer advection time step. \n"//& - "Ideally DT_THERM should be an integer multiple of DT \n"//& - "and less than the forcing or coupling time-step, unless \n"//& - "THERMO_SPANS_COUPLING is true, in which case DT_THERM \n"//& - "can be an integer multiple of the coupling timestep. By \n"//& + "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=dt) call get_param(param_file, mod_name, "DIABATIC_FIRST", diabatic_first, & - "If true, apply diabatic and thermodynamic processes, \n"//& - "including buoyancy forcing and mass gain or loss, \n"//& + "If true, apply diabatic and thermodynamic processes, "//& + "including buoyancy forcing and mass gain or loss, "//& "before stepping the dynamics forward.", default=.false.) @@ -411,19 +411,19 @@ program MOM_main "MOM_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 \n"//& - "written. Add 2 (bit 1) for a time-stamped file, and odd \n"//& - "(bit 0) for a non-time-stamped file. A non-time-stamped \n"//& - "restart file is saved at the end of the run segment \n"//& + "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 \n"//& - "of TIMEUNIT. Use 0 (the default) to not save \n"//& + "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 \n"//& - "time. If this is not positive, do not check cpu time, and \n"//& + "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 get_param(param_file, "MOM", "DEBUG", debug, & diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 75a1ec321a..6fe06daea8 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1392,7 +1392,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! 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 \n"//& + "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.", & @@ -1400,39 +1400,39 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is \n"//& - "true. This assumes that KD = KDML = 0.0 and that \n"//& - "there is no buoyancy forcing, but makes the model \n"//& + "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 \n"//& + "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 \n"//& - "is specified. Valid options include (file), (zero), \n"//& + "The character string that indicates how buoyancy forcing "//& + "is specified. Valid options include (file), (zero), "//& "(linear), (USER), (BFB) and (NONE).", fail_if_missing=.true.) 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 \n"//& - "the old German OMIP prescription that predated CORE. If \n"//& - "false, use the variable groupings available from MOM \n"//& + "If true, use the forcing variable decomposition from "//& + "the old German OMIP prescription that predated CORE. If "//& + "false, use the variable groupings available from MOM "//& "output diagnostics of forcing variables.", default=.true.) if (CS%archaic_OMIP_file) then call get_param(param_file, mdl, "LONGWAVEDOWN_FILE", CS%longwave_file, & - "The file with the downward longwave heat flux, in \n"//& + "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 \n"//& + "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 \n"//& + "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 \n"//& + "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.", & @@ -1441,13 +1441,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "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 \n"//& + "The file with the downward frozen precip flux, in "//& "variable snow.", fail_if_missing=.true.) call get_param(param_file, mdl, "PRECIP_FILE", CS%rain_file, & - "The file with the downward total precip flux, in \n"//& + "The file with the downward total precip flux, in "//& "variable precip.", fail_if_missing=.true.) call get_param(param_file, mdl, "FRESHDISCHARGE_FILE", CS%runoff_file, & - "The file with the fresh and frozen runoff/calving fluxes, \n"//& + "The file with the fresh and frozen runoff/calving fluxes, "//& "invariables disch_w and disch_s.", fail_if_missing=.true.) ! These variable names are hard-coded, per the archaic OMIP conventions. @@ -1458,52 +1458,52 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C else call get_param(param_file, mdl, "LONGWAVE_FILE", CS%longwave_file, & - "The file with the longwave heat flux, in the variable \n"//& + "The file with the longwave heat flux, in the variable "//& "given by LONGWAVE_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "LONGWAVE_FORCING_VAR", CS%LW_var, & "The variable with the longwave forcing field.", default="LW") call get_param(param_file, mdl, "SHORTWAVE_FILE", CS%shortwave_file, & - "The file with the shortwave heat flux, in the variable \n"//& + "The file with the shortwave heat flux, in the variable "//& "given by SHORTWAVE_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SHORTWAVE_FORCING_VAR", CS%SW_var, & "The variable with the shortwave forcing field.", default="SW") call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & - "The file with the evaporative moisture flux, in the \n"//& + "The file with the evaporative moisture flux, in the "//& "variable given by EVAP_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "EVAP_FORCING_VAR", CS%evap_var, & "The variable with the evaporative moisture flux.", & default="evap") call get_param(param_file, mdl, "LATENTHEAT_FILE", CS%latentheat_file, & - "The file with the latent heat flux, in the variable \n"//& + "The file with the latent heat flux, in the variable "//& "given by LATENT_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "LATENT_FORCING_VAR", CS%latent_var, & "The variable with the latent heat flux.", default="latent") call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & - "The file with the sensible heat flux, in the variable \n"//& + "The file with the sensible heat flux, in the variable "//& "given by SENSIBLE_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SENSIBLE_FORCING_VAR", CS%sens_var, & "The variable with the sensible heat flux.", default="sensible") call get_param(param_file, mdl, "RAIN_FILE", CS%rain_file, & - "The file with the liquid precipitation flux, in the \n"//& + "The file with the liquid precipitation flux, in the "//& "variable given by RAIN_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "RAIN_FORCING_VAR", CS%rain_var, & "The variable with the liquid precipitation flux.", & default="liq_precip") call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & - "The file with the frozen precipitation flux, in the \n"//& + "The file with the frozen precipitation flux, in the "//& "variable given by SNOW_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SNOW_FORCING_VAR", CS%snow_var, & "The variable with the frozen precipitation flux.", & default="froz_precip") call get_param(param_file, mdl, "RUNOFF_FILE", CS%runoff_file, & - "The file with the fresh and frozen runoff/calving \n"//& - "fluxes, in variables given by LIQ_RUNOFF_FORCING_VAR \n"//& + "The file with the fresh and frozen runoff/calving "//& + "fluxes, in variables given by LIQ_RUNOFF_FORCING_VAR "//& "and FROZ_RUNOFF_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "LIQ_RUNOFF_FORCING_VAR", CS%lrunoff_var, & "The variable with the liquid runoff flux.", & @@ -1514,10 +1514,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C endif call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in the \n"//& + "The file with the SST toward which to restore in the "//& "variable given by SST_RESTORE_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SALINITYRESTORE_FILE", CS%salinityrestore_file, & - "The file with the surface salinity toward which to \n"//& + "The file with the surface salinity toward which to "//& "restore in the variable given by SSS_RESTORE_VAR.", & fail_if_missing=.true.) @@ -1549,17 +1549,17 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%salinityrestore_file = trim(CS%inputdir)//trim(CS%salinityrestore_file) elseif (trim(CS%buoy_config) == "const") then call get_param(param_file, mdl, "SENSIBLE_HEAT_FLUX", CS%constantHeatForcing, & - "A constant heat forcing (positive into ocean) applied \n"//& + "A constant heat forcing (positive into ocean) applied "//& "through the sensible heat flux field. ", & units='W/m2', fail_if_missing=.true.) endif call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & - "The character string that indicates how wind forcing \n"//& - "is specified. Valid options include (file), (2gyre), \n"//& + "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 \n"//& + "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.", & @@ -1568,37 +1568,37 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "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 \n"//& + "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") call get_param(param_file, mdl, "USTAR_FORCING_VAR", CS%ustar_var, & - "The name of the friction velocity variable in WIND_FILE \n"//& - "or blank to get ustar from the wind stresses plus the \n"//& + "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") CS%wind_file = trim(CS%inputdir) // trim(CS%wind_file) 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 \n"//& - "zonal wind stress profile: \n"//& + "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 \n"//& - "zonal wind stress profile: \n"//& + "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 \n"//& - "the zonal wind stress profile: \n"//& + "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 \n"//& - "the zonal wind stress profile: \n"//& + "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 @@ -1610,14 +1610,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C 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 \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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 \n"//& - "toward some specified surface state with a rate \n"//& + "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) @@ -1625,20 +1625,20 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The latent heat of fusion.", units="J/kg", default=hlv) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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.) if (CS%use_temperature) then call get_param(param_file, mdl, "FLUXCONST_T", CS%Flux_const_T, & - "The constant that relates the restoring surface temperature\n"//& - "flux to the relative surface anomaly (akin to a piston \n"//& + "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) call get_param(param_file, mdl, "FLUXCONST_S", CS%Flux_const_S, & - "The constant that relates the restoring surface salinity\n"//& - "flux to the relative surface anomaly (akin to a piston \n"//& + "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) endif @@ -1650,20 +1650,20 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C 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 \n"//& - "at the northern end of the domain toward which to \n"//& + "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 \n"//& - "at the southern end of the domain toward which to \n"//& + "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 \n"//& - "at the northern end of the domain toward which to \n"//& + "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 \n"//& - "at the southern end of the domain toward which to \n"//& + "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 @@ -1675,11 +1675,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "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 \n"//& + "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 \n"//& + "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) filename = trim(CS%inputdir) // trim(gust_file) @@ -1704,10 +1704,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call idealized_hurricane_wind_init(Time, G, 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\n"//& + "With wind_config const, this is the constant zonal "//& "wind-stress", units="Pa", 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\n"//& + "With wind_config const, this is the constant meridional "//& "wind-stress", units="Pa", fail_if_missing=.true.) elseif (trim(CS%wind_config) == "SCM_CVmix_tests" .or. & trim(CS%buoy_config) == "SCM_CVmix_tests") then diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index 94726a62c3..71e91a539c 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -233,16 +233,16 @@ subroutine Neverland_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "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) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, & @@ -250,14 +250,14 @@ subroutine Neverland_surface_forcing_init(Time, G, param_file, diag, CS) ! default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "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 \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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. diff --git a/config_src/solo_driver/coupler_types.F90 b/config_src/solo_driver/coupler_types.F90 deleted file mode 100644 index 10d22a8eff..0000000000 --- a/config_src/solo_driver/coupler_types.F90 +++ /dev/null @@ -1,3310 +0,0 @@ -!> This module contains the coupler-type declarations and methods for use in -!! ocean-only configurations of MOM6. -!! -!! It is intended that the version of coupler_types_mod that is avialable from -!! FMS will conform to this version with the FMS city release after warsaw. - -module coupler_types_mod - -! This file is part of MOM6. See LICENSE.md for the license. - -use fms_io_mod, only: restart_file_type, register_restart_field -use fms_io_mod, only: query_initialized, restore_state -use time_manager_mod, only: time_type -use diag_manager_mod, only: register_diag_field, send_data -use data_override_mod, only: data_override -use mpp_domains_mod, only: domain2D, mpp_redistribute -use mpp_mod, only: stdout, mpp_error, FATAL, mpp_chksum - -implicit none ; private - -public coupler_type_copy, coupler_type_spawn, coupler_type_set_diags -public coupler_type_write_chksums, coupler_type_send_data, coupler_type_data_override -public coupler_type_register_restarts, coupler_type_restore_state -public coupler_type_increment_data, coupler_type_rescale_data -public coupler_type_copy_data, coupler_type_redistribute_data -public coupler_type_destructor, coupler_type_initialized -public coupler_type_extract_data, coupler_type_set_data - -public coupler_type_copy_1d_2d -public coupler_type_copy_1d_3d - - -! -! 3-d fields -! -!> A type with a 3-d array of values and metadata -type, public :: coupler_3d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_3d_values_type - -!> A field with one or more related 3-d variables and collective metadata -type, public :: coupler_3d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_3d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_3d_field_type - -!> A collection of 3-D boundary conditions for exchange between components -type, public :: coupler_3d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - !>@{ The i- and j-direction data and computational domain index ranges for this type - integer :: isd, isc, iec, ied ! The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed ! The j-direction data and computational domain index ranges for this type - !!@} - integer :: ks !< The k-direction start index for this type - integer :: ke !< The k-direction end index for this type -end type coupler_3d_bc_type - -! -! 2-d fields -! -!> A type with a 2-d array of values and metadata -type, public :: coupler_2d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_2d_values_type - -!> A field with one or more related 2-d variables and collective metadata -type, public :: coupler_2d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_2d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_2d_field_type - -!> A collection of 2-D boundary conditions for exchange between components -type, public :: coupler_2d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - !>@{ The i- and j-direction data and computational domain index ranges for this type - integer :: isd, isc, iec, ied ! The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed ! The j-direction data and computational domain index ranges for this type - !!@} -end type coupler_2d_bc_type - -! -! 1-d fields -! -!> A type with a 1-d array of values and metadata -type, public :: coupler_1d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, dimension(:) :: values => NULL() !< The pointer to the array of values - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_1d_values_type - -!> A field with one or more related 1-d variables and collective metadata -type, public :: coupler_1d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_1d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_1d_field_type - -!> A collection of 1-D boundary conditions for exchange between components -type, public :: coupler_1d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized -end type coupler_1d_bc_type - -!---------------------------------------------------------------------- -! The following public parameters can help in selecting the sub-elements of a -! coupler type. There are duplicate values because different boundary -! conditions have different sub-elements. -integer, parameter, public :: ind_pcair = 1 !< The index of the atmospheric concentration -integer, parameter, public :: ind_u10 = 2 !< The index of the 10 m wind speed -integer, parameter, public :: ind_psurf = 3 !< The index of the surface atmospheric pressure -integer, parameter, public :: ind_alpha = 1 !< The index of the solubility array for a tracer -integer, parameter, public :: ind_csurf = 2 !< The index of the ocean surface concentration -integer, parameter, public :: ind_sc_no = 3 !< The index for the Schmidt number for a tracer flux -integer, parameter, public :: ind_flux = 1 !< The index for the tracer flux -integer, parameter, public :: ind_deltap= 2 !< The index for ocean-air gas partial pressure change -integer, parameter, public :: ind_kw = 3 !< The index for the piston velocity -integer, parameter, public :: ind_deposition = 1 !< The index for the atmospheric deposition flux -integer, parameter, public :: ind_runoff = 1 !< The index for a runoff flux - -!---------------------------------------------------------------------- -! Interface definitions for overloaded routines -!---------------------------------------------------------------------- - -!> This is the interface to spawn one coupler_bc_type into another and then -!! register diagnostics associated with the new type. -interface coupler_type_copy - module procedure coupler_type_copy_1d_2d, coupler_type_copy_1d_3d - module procedure coupler_type_copy_2d_2d, coupler_type_copy_2d_3d - module procedure coupler_type_copy_3d_2d, coupler_type_copy_3d_3d -end interface coupler_type_copy - -!> This is the interface to spawn one coupler_bc_type into another. -interface coupler_type_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d, CT_spawn_3d_2d - module procedure CT_spawn_1d_3d, CT_spawn_2d_3d, CT_spawn_3d_3d -end interface coupler_type_spawn - -!> This is the interface to copy the field data from one coupler_bc_type -!! to another of the same rank, size and decomposition. -interface coupler_type_copy_data - module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d -end interface coupler_type_copy_data - -!> This is the interface to redistribute the field data from one coupler_bc_type -!! to another of the same rank and global size, but a different decomposition. -interface coupler_type_redistribute_data - module procedure CT_redistribute_data_2d, CT_redistribute_data_3d -end interface coupler_type_redistribute_data - -!> This is the interface to rescale the field data in a coupler_bc_type. -interface coupler_type_rescale_data - module procedure CT_rescale_data_2d, CT_rescale_data_3d -end interface coupler_type_rescale_data - -!> This is the interface to increment the field data from one coupler_bc_type -!! with the data from another. Both must have the same horizontal size and -!! decomposition, but a 2d type may be incremented by a 2d or 3d type -interface coupler_type_increment_data - module procedure CT_increment_data_2d_2d, CT_increment_data_3d_3d, CT_increment_data_2d_3d -end interface coupler_type_increment_data - -!> This is the interface to extract a field in a coupler_bc_type into an array. -interface coupler_type_extract_data - module procedure CT_extract_data_2d, CT_extract_data_3d, CT_extract_data_3d_2d -end interface coupler_type_extract_data - -!> This is the interface to set a field in a coupler_bc_type from an array. -interface coupler_type_set_data - module procedure CT_set_data_2d, CT_set_data_3d, CT_set_data_2d_3d -end interface coupler_type_set_data - -!> This is the interface to set diagnostics for the arrays in a coupler_bc_type. -interface coupler_type_set_diags - module procedure CT_set_diags_2d, CT_set_diags_3d -end interface coupler_type_set_diags - -!> This is the interface to write out checksums for the elements of a coupler_bc_type. -interface coupler_type_write_chksums - module procedure CT_write_chksums_2d, CT_write_chksums_3d -end interface coupler_type_write_chksums - -!> This is the interface to write out diagnostics of the arrays in a coupler_bc_type. -interface coupler_type_send_data - module procedure CT_send_data_2d, CT_send_data_3d -end interface coupler_type_send_data - -!> This is the interface to override the values of the arrays in a coupler_bc_type. -interface coupler_type_data_override - module procedure CT_data_override_2d, CT_data_override_3d -end interface coupler_type_data_override - -!> This is the interface to register the fields in a coupler_bc_type to be saved -!! in restart files. -interface coupler_type_register_restarts - module procedure CT_register_restarts_2d, CT_register_restarts_3d - module procedure CT_register_restarts_to_file_2d, CT_register_restarts_to_file_3d -end interface coupler_type_register_restarts - -!> This is the interface to read in the fields in a coupler_bc_type that have -!! been saved in restart files. -interface coupler_type_restore_state - module procedure CT_restore_state_2d, CT_restore_state_3d -end interface coupler_type_restore_state - -!> This function interface indicates whether a coupler_bc_type has been initialized. -interface coupler_type_initialized - module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d -end interface coupler_type_initialized - -!> This is the interface to deallocate any data associated with a coupler_bc_type. -interface coupler_type_destructor - module procedure CT_destructor_1d, CT_destructor_2d, CT_destructor_3d -end interface coupler_type_destructor - -contains - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 1-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_1d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_1d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_1d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 1-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_1d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_1d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_1d_3d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 2-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_2d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_2d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_2d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 2-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_2d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_2d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_2d_3d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 3-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_3d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_3d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_3d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 3-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_3d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_3d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_3d_3d - - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 1-D to 2-D version for generic coupler_type_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var_out, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_1d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_1d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 1-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_1d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_1d_3d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 2-D to 2-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_2d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_2d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 2-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_2d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_2d_3d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 3-D to 2-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_3d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_3d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 3-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -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. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_3d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_3d_3d - - -!> This subroutine does a direct copy of the data in all elements of one -!! 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 - logical :: copy_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_2d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_2d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_2d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_2d - -!> This subroutine does a direct copy of the data in all elements of one -!! coupler_3d_bc_type into another. Both types 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 - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is a k-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc ; k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_3d - -!> This subroutine does a direct copy of the data in all elements of a -!! coupler_2d_bc_type into a coupler_3d_bc_type. Both types must have the same -!! array sizes for their 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. - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, ks, ke - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the output structure.") - endif - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var_in%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var_in%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var_in%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - ks = var%ks ; if (present(ind3_start)) ks = max(ks, ind3_start) - ke = var%ke ; if (present(ind3_end)) ke = max(ke, ind3_end) - do k=ks,ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_2d_3d - - -!> This subroutine redistributes 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 (intent in) - 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 - - real, pointer, dimension(:,:) :: null_ptr2D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. ; if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 ; fc_out = 0 - if (do_in) then ; do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo ; enddo ; endif - if (fc_in == 0) do_in = .false. - if (do_out) then ; do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo ; enddo ; endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL, & - "Mismatch in num_bcs in CT_copy_data_2d.") - if (fc_in /= fc_out) call mpp_error(FATAL, & - "Mismatch in the total number of fields in CT_redistribute_data_2d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv. & - associated(var_out%bc(n)%field(m)%values) ) & - call mpp_error(FATAL, & - "Mismatch in which fields are associated in CT_redistribute_data_2d.") - - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_in) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, null_ptr2D, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_out) then - do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr2D, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo ; enddo - endif - -end subroutine CT_redistribute_data_2d - -!> This subroutine redistributes 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_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 (intent in) - 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 - - real, pointer, dimension(:,:,:) :: null_ptr3D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. ; if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 ; fc_out = 0 - if (do_in) then ; do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo ; enddo ; endif - if (fc_in == 0) do_in = .false. - if (do_out) then ; do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo ; enddo ; endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL, & - "Mismatch in num_bcs in CT_copy_data_3d.") - if (fc_in /= fc_out) call mpp_error(FATAL, & - "Mismatch in the total number of fields in CT_redistribute_data_3d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv. & - associated(var_out%bc(n)%field(m)%values) ) & - call mpp_error(FATAL, & - "Mismatch in which fields are associated in CT_redistribute_data_3d.") - - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_in) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, null_ptr3D, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_out) then - do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr3D, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo ; enddo - endif - -end subroutine CT_redistribute_data_3d - - -!> This subroutine 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, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - 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 - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or - !! the full arrays if scale is 0. - 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 - logical :: do_bc - integer :: i, j, m, n, n1, n2, halo - - if (present(bc_index)) then - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.") - if (present(field_index)) then ; if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_2d: Excessive i-direction halo size.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_2d: Excessive j-direction halo size.") - endif - - do n = n1, n2 - - do_bc = .true. - if (do_bc .and. present(exclude_flux_type)) & - do_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (do_bc .and. present(only_flux_type)) & - do_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (do_bc .and. present(pass_through_ice)) & - do_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.do_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - if (scale == 0.0) then - if (present(halo_size)) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = 0.0 - enddo ; enddo - else - var%bc(n)%field(m)%values(:,:) = 0.0 - endif - else - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = scale * var%bc(n)%field(m)%values(i,j) - enddo ; enddo - endif - endif - enddo - enddo - -end subroutine CT_rescale_data_2d - -!> This subroutine 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, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - 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 - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or - !! the full arrays if scale is 0. - 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 - logical :: do_bc - integer :: i, j, k, m, n, n1, n2, halo - - if (present(bc_index)) then - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.") - if (present(field_index)) then ; if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_3d: Excessive i-direction halo size.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_3d: Excessive j-direction halo size.") - endif - - do n = n1, n2 - - do_bc = .true. - if (do_bc .and. present(exclude_flux_type)) & - do_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (do_bc .and. present(only_flux_type)) & - do_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (do_bc .and. present(pass_through_ice)) & - do_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.do_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - if (scale == 0.0) then - if (present(halo_size)) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = 0.0 - enddo ; enddo ; enddo - else - var%bc(n)%field(m)%values(:,:,:) = 0.0 - endif - else - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = scale * var%bc(n)%field(m)%values(i,j,k) - enddo ; enddo ; enddo - endif - endif - enddo - enddo - -end subroutine CT_rescale_data_3d - - -!> This subroutine does a direct increment of the data in all elements of one -!! coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, 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 add to the other type - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 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 - 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. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_2d_2d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_2d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_2d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = sc_prev * var%bc(n)%field(m)%values(i,j) + & - scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_2d_2d - - -!> This subroutine does a direct increment of the data in all elements of one -!! coupler_3d_bc_type into another. Both must have the same array sizes. -subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, 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 add to the other type - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - 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 - 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. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_3d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is a k-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc ; k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = sc_prev * var%bc(n)%field(m)%values(i,j,k) + & - scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_3d_3d - -!> This subroutine does increments the data in the elements of a coupler_2d_bc_type -!! with the weighed average of the elements of a coupler_3d_bc_type. Both must have -!! the same horizontal array sizes and the normalized weight array must match the -!! array sizes of the coupler_3d_bc_type. -subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, 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 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 BC_type structure whose fields are being incremented - 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 - 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. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, k, m, n, n1, n2, halo - integer :: io1, jo1, iow, jow, kow ! Offsets to account for different index conventions. - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_2d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is a j-direction computional domain size mismatch.") - if ((1+var_in%ke-var_in%ks) /= size(weights,3)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is a k-direction size mismatch with the weights array.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive j-direction halo size for the output structure.") - - if ((1+var%iec-var%isc) == size(weights,1)) then - iow = 1 - var%isc - elseif ((1+var%ied-var%isd) == size(weights,1)) then - iow = 1 - var%isd - elseif ((1+var_in%ied-var_in%isd) == size(weights,1)) then - iow = 1 + (var_in%isc - var_in%isd) - var%isc - else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size "//& - "of a computational or data domain.") - endif - if ((1+var%jec-var%jsc) == size(weights,2)) then - jow = 1 - var%jsc - elseif ((1+var%jed-var%jsd) == size(weights,2)) then - jow = 1 - var%jsd - elseif ((1+var_in%jed-var_in%jsd) == size(weights,2)) then - jow = 1 + (var_in%jsc - var_in%jsd) - var%jsc - else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size "//& - "of a computational or data domain.") - endif - - io1 = var_in%isc - var%isc ; jo1 = var_in%jsc - var%jsc ; kow = 1 - var_in%ks - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var_in%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var_in%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var_in%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var_in%ks,var_in%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = sc_prev * var%bc(n)%field(m)%values(i,j) + & - (scale * weights(i+iow,j+jow,k+kow)) * var_in%bc(n)%field(m)%values(i+io1,j+io1,k) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_2d_3d - - -!> This subroutine extracts a single 2-d field from a coupler_2d_bc_type into -!! a two-dimensional array. -subroutine CT_extract_data_2d(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 - 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j) - enddo ; enddo - -end subroutine CT_extract_data_2d - -!> This subroutine extracts a single k-level of a 3-d field from a coupler_3d_bc_type -!! into a two-dimensional array. -subroutine CT_extract_data_3d_2d(var_in, bc_index, field_index, k_in, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_3d_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 - integer, intent(in) :: k_in !< The k-index to extract - 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_3d_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if ((k_in > var_in%ke) .or. (k_in < var_in%ks)) then - write (error_msg, *) trim(error_header), ' The extracted k-index of ', k_in, & - ' is outside of the valid range of ', var_in%ks, ' to ', var_in%ke - call mpp_error(FATAL, trim(error_msg)) - endif - - do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k_in) - enddo ; enddo - -end subroutine CT_extract_data_3d_2d - -!> This subroutine extracts a single 3-d field from a coupler_3d_bc_type into -!! a three-dimensional array. -subroutine CT_extract_data_3d(var_in, bc_index, field_index, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_3d_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 - real, dimension(1:,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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_3d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off, k_off - - if (bc_index <= 0) then - array_out(:,:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if (size(array_out,3) /= 1 + var_in%ke - var_in%ks) then - write (error_msg, *) trim(error_header), ' The target array with k-dimension size ', & - size(array_out,3), ' does not match the data of size ', & - (1 + var_in%ke - var_in%ks) - call mpp_error(FATAL, trim(error_msg)) - endif - k_off = 1 - var_in%ks - - do k=var_in%ks,var_in%ke ; do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off,k+k_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k) - enddo ; enddo ; enddo - -end subroutine CT_extract_data_3d - - -!> This subroutine sets a single 2-d field in a coupler_3d_bc_type from -!! a two-dimensional array. -subroutine CT_set_data_2d(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 copied - 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j) = scale * array_in(i+i_off,j+j_off) - enddo ; enddo - -end subroutine CT_set_data_2d - -!> This subroutine sets a one k-level of a single 3-d field in a -!! coupler_3d_bc_type from a two-dimensional array. -subroutine CT_set_data_2d_3d(array_in, bc_index, field_index, k_out, 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 copied - integer, intent(in) :: k_out !< The k-index to set - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_3d_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - if ((k_out > var%ke) .or. (k_out < var%ks)) then - write (error_msg, *) trim(error_header), ' The seted k-index of ', k_out, & - ' is outside of the valid range of ', var%ks, ' to ', var%ke - call mpp_error(FATAL, trim(error_msg)) - endif - - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j,k_out) = scale * array_in(i+i_off,j+j_off) - enddo ; enddo - -end subroutine CT_set_data_2d_3d - -!> This subroutine sets a single 3-d field in a coupler_3d_bc_type from -!! a three-dimensional array. -subroutine CT_set_data_3d(array_in, bc_index, field_index, var, & - scale_factor, halo_size, idim, jdim) - real, dimension(1:,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 copied - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be 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 - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_3d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off, k_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - if (size(array_in,3) /= 1 + var%ke - var%ks) then - write (error_msg, *) trim(error_header), ' The target array with k-dimension size ', & - size(array_in,3), ' does not match the data of size ', & - (1 + var%ke - var%ks) - call mpp_error(FATAL, trim(error_msg)) - endif - k_off = 1 - var%ks - - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j,k) = scale * array_in(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - -end subroutine CT_set_data_3d - - -!> This routine registers the diagnostics of a coupler_2d_bc_type. -subroutine CT_set_diags_2d(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--if blank, - !! then don't 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 - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 2) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - '(coupler_types_set_diags_3d): axes has less than 2 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name, & - var%bc(n)%field(m)%name, axes(1:2), Time, & - var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units ) - enddo - enddo - -end subroutine CT_set_diags_2d - -!> This routine registers the diagnostics of a coupler_3d_bc_type. -subroutine CT_set_diags_3d(var, diag_name, axes, time) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't 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 - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 3) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - '(coupler_types_set_diags_3d): axes has less than 3 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name, & - var%bc(n)%field(m)%name, axes(1:3), Time, & - var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units ) - enddo - enddo - -end subroutine CT_set_diags_3d - - -!> This subroutine writes out all diagnostics of elements of a coupler_2d_bc_type -subroutine CT_send_data_2d(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 - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_send_data_2d - -!> This subroutine writes out all diagnostics of elements of a coupler_2d_bc_type -subroutine CT_send_data_3d(var, Time) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_send_data_3d - - -!> This subroutine registers the fields in a coupler_2d_bc_type to be saved -!! in restart files specified in the field table. -subroutine CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m - - ocn_rest = .true. ; if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = register_restart_field(bc_rest_files(f), & - rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_2d - -!> This subroutine registers the fields in a coupler_2d_bc_type to be saved -!! in the specified restart file. -subroutine CT_register_restarts_to_file_2d(var, file_name, rest_file, mpp_domain, & - varname_prefix) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = register_restart_field(rest_file, & - file_name, var_name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_to_file_2d - -!> This subroutine registers the fields in a coupler_3d_bc_type to be saved -!! in restart files specified in the field table. -subroutine CT_register_restarts_3d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m, id_restart - - ocn_rest = .true. ; if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = register_restart_field(bc_rest_files(f), & - rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_3d - -!> This subroutine registers the fields in a coupler_3d_bc_type to be saved -!! in the specified restart file. -subroutine CT_register_restarts_to_file_3d(var, file_name, rest_file, mpp_domain, & - varname_prefix) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = register_restart_field(rest_file, & - file_name, var_name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_to_file_3d - - -!> This subroutine reads in the fields in a coupler_2d_bc_type that have -!! been saved in restart files. -subroutine CT_restore_state_2d(var, directory, all_or_nothing, & - all_required, test_by_field) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. ; all_set = .true. ; num_fld = 0 ; unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. ; all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest, & - directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL, & - "CT_restore_state_2d: test_by_field is true, and "//& - trim(unset_varname)//" was not read but some other fields in "//& - trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL, & - "CT_restore_state_2d: all_or_nothing is true, and "//& - trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then ; if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_2d: all_required is true, but "//& - trim(unset_varname)//" was not read from its restart file.") - endif ; endif - -end subroutine CT_restore_state_2d - -!> This subroutine reads in the fields in a coupler_3d_bc_type that have -!! been saved in restart files. -subroutine CT_restore_state_3d(var, directory, all_or_nothing, & - all_required, test_by_field) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. ; all_set = .true. ; num_fld = 0 ; unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. ; all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest, & - directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL, & - "CT_restore_state_3d: test_by_field is true, and "//& - trim(unset_varname)//" was not read but some other fields in "//& - trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL, & - "CT_restore_state_3d: all_or_nothing is true, and "//& - trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then ; if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_3d: all_required is true, but "//& - trim(unset_varname)//" was not read from its restart file.") - endif ; endif - -end subroutine CT_restore_state_3d - - -!> This subroutine potentially overrides the values in a coupler_2d_bc_type -subroutine CT_data_override_2d(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 - - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_data_override_2d - -!> This subroutine potentially overrides the values in a coupler_3d_bc_type -subroutine CT_data_override_3d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_data_override_3d - - -!> This subroutine writes 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 - - character(len=120) :: var_name - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') trim(var_name), & - mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec) ) - enddo ; enddo - -end subroutine CT_write_chksums_2d - -!> This subroutine writes 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 - - character(len=120) :: var_name - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') var_name, & - mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec,:) ) - enddo ; enddo - -end subroutine CT_write_chksums_3d - - -!> This function indicates whether a coupler_1d_bc_type has been initialized. -function CT_initialized_1d(var) - type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_1d !< The return value, indicating whether this type has been initialized - - CT_initialized_1d = var%set -end function CT_initialized_1d - -!> This function indicates whether a coupler_2d_bc_type has been initialized. -function CT_initialized_2d(var) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_2d !< The return value, indicating whether this type has been initialized - - CT_initialized_2d = var%set -end function CT_initialized_2d - -!> This function indicates whether a coupler_3d_bc_type has been initialized. -function CT_initialized_3d(var) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_3d !< The return value, indicating whether this type has been initialized - - CT_initialized_3d = var%set -end function CT_initialized_3d - - -!> This subroutine deallocates 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 - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_1d - -!> This subroutine deallocates 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 - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_2d - - -!> This subroutine deallocates all data associated with a coupler_3d_bc_type -subroutine CT_destructor_3d(var) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_3d - -end module coupler_types_mod diff --git a/config_src/solo_driver/coupler_util.F90 b/config_src/solo_driver/coupler_util.F90 deleted file mode 100644 index cc63a9563d..0000000000 --- a/config_src/solo_driver/coupler_util.F90 +++ /dev/null @@ -1,135 +0,0 @@ -!> Provides a couple of interfaces to allow more transparent and -!! robust extraction of the various fields in the coupler types. -module coupler_util - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use coupler_types_mod, only : coupler_2d_bc_type, ind_flux, ind_alpha -use coupler_types_mod, only : ind_csurf - -implicit none ; private - -public :: extract_coupler_values, set_coupler_values -public :: ind_flux, ind_alpha, ind_csurf - -contains - -!> Extract an array of values in a coupler bc type -subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, & - is, ie, js, je, conversion) - 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. - real, dimension(:,:), intent(out) :: array_out !< The array being filled with the input values. - integer, optional, intent(in) :: is !< Start i-index - integer, optional, intent(in) :: ie !< End i-index - integer, optional, intent(in) :: js !< Start j-index - integer, optional, intent(in) :: je !< End j-index - real, optional, intent(in) :: conversion !< A number that every element is multiplied by, to - ! Local variables - real, pointer, dimension(:,:) :: Array_in - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_in => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_out,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_out,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_out,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_out,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_in,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - if (size(Array_in,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - i_offset = lbound(Array_in,1) - is0 - j_offset = lbound(Array_in,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - array_out(i,j) = conv * Array_in(i+i_offset,j+j_offset) - enddo ; enddo - -end subroutine extract_coupler_values - -!> Set an array of values in a coupler bc type -subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, & - is, ie, js, je, conversion) - real, dimension(:,:), 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 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 !< Start i-index - integer, optional, intent(in) :: ie !< End i-index - integer, optional, intent(in) :: js !< Start j-index - integer, optional, intent(in) :: je !< End j-index - real, optional, intent(in) :: conversion !< A number that every element is multiplied by, to - !! permit sign convention or unit conversion. - ! Local variables - real, pointer, dimension(:,:) :: Array_out - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_out => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_in,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_in,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_in,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_in,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_out,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - if (size(Array_out,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - i_offset = lbound(Array_out,1) - is0 - j_offset = lbound(Array_out,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - Array_out(i+i_offset,j+j_offset) = conv * array_in(i,j) - enddo ; enddo - -end subroutine set_coupler_values - -end module coupler_util diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index a9787b9348..5ff39ae8c4 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -256,16 +256,16 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "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) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, & @@ -273,13 +273,13 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "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 \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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. diff --git a/docs/README.md b/docs/README.md index aafe349ebc..8870a46a26 100644 --- a/docs/README.md +++ b/docs/README.md @@ -38,11 +38,11 @@ If you are building the full generated sphinx documentation you will need the fo (.e.g `apt-get install libxml2-dev libxslt-dev`) -Before running sphinc (`make html`) you will need to issue: +Before running sphinx (`make html`) you will need to issue: ```bash pip install -r requirements.txt ``` ## Credits -The sphinx documentation of MOM6 is made possible by modifications by Angus Gibson to two packages, [sphinx-fortran](https://github.com/angus-g/sphinx-fortran) and [autodoc_doxygen](https://github.com/angus-g/sphinxcontrib-autodoc_doxygen). +The sphinx documentation of MOM6 is made possible by modifications by [Angus Gibson](https://github.com/angus-g) to two packages, [sphinx-fortran](https://github.com/angus-g/sphinx-fortran) and [autodoc_doxygen](https://github.com/angus-g/sphinxcontrib-autodoc_doxygen). diff --git a/docs/equations/ALE-algorithm.rst b/docs/equations/ALE-algorithm.rst index 694b050b8e..28e808f254 100644 --- a/docs/equations/ALE-algorithm.rst +++ b/docs/equations/ALE-algorithm.rst @@ -5,24 +5,24 @@ The semi-discrete, vertically integrated, Boussinesq hydrostatic equations of motion in general-coordinate :math:`r` are .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \delta_k \Phi + \delta_k p &= 0 \\ - \partial_t h + \nabla_r \cdot ( h \vec{u} ) + \delta_k ( z_r \dot{r} ) &= 0 \\ - \partial_t h \theta + \nabla_r \cdot ( h \vec{u} \theta ) + \delta_k ( z_r \dot{r} \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t h S + \nabla_r \cdot ( h \vec{u} S ) + \delta_k ( z_r \dot{r} S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o}\boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdot \boldsymbol{\underline{\tau}} ,\\ + \rho \delta_k \Phi + \delta_k p &= 0 ,\\ + \partial_t h + \nabla_r \cdot ( h \boldsymbol{u} ) + \delta_k ( z_r \dot{r} ) &= 0 ,\\ + \partial_t (h \theta) + \nabla_r \cdot ( h \boldsymbol{u} \theta ) + \delta_k ( z_r \dot{r} \theta ) &= \boldsymbol{\nabla} \cdot \boldsymbol{Q}_\theta ,\\ + \partial_t (h S) + \nabla_r \cdot ( h \boldsymbol{u} S ) + \delta_k ( z_r \dot{r} S ) &= \boldsymbol{\nabla} \cdot \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) . The Arbitrary-Lagrangian-Eulerian algorithm we use is quasi-Lagrangian in that in the first (Lagrangian) phase, regardless of the current mesh (or coordinate :math:`r`) we integrate the equations forward with :math:`\dot{r}=0`, i.e.: .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \delta_k \Phi + \delta_k p &= 0 \\ - \partial_t h + \nabla_r \cdot ( h \vec{u} ) &= 0 \\ - \partial_t h \theta + \nabla_r \cdot ( h \vec{u} \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t h S + \nabla_r \cdot ( h \vec{u} S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o}\boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdot \boldsymbol{\underline{\tau}} ,\\ + \rho \delta_k \Phi + \delta_k p &= 0 ,\\ + \partial_t h + \nabla_r \cdot ( h \boldsymbol{u} ) &= 0 ,\\ + \partial_t (h \theta) + \nabla_r \cdot ( h \boldsymbol{u} \theta ) &= \boldsymbol{\nabla} \cdot \boldsymbol{Q}_\theta ,\\ + \partial_t (h S) + \nabla_r \cdot ( h \boldsymbol{u} S ) &= \boldsymbol{\nabla} \cdot \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) . Notice that by setting :math:`\dot{r}=0` all the terms with the metric :math:`z_r` disappeared. @@ -31,4 +31,3 @@ After a finite amount of time, the mesh (:math:`h`) may become very distorted or unrelated to the intended mesh. At any point in time, we can simply define a new mesh and remap from the current mesh to the new mesh without an explicit change in the physical state. - diff --git a/docs/equations/general_coordinate.rst b/docs/equations/general_coordinate.rst index 377adc9421..6e35dacdd1 100644 --- a/docs/equations/general_coordinate.rst +++ b/docs/equations/general_coordinate.rst @@ -9,9 +9,9 @@ The Boussinesq hydrostatic equations of motion in general-coordinate :math:`r` are .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \partial_z \Phi + \partial_z p &= 0 \\ - \partial_t z_r + \nabla_r \cdot ( z_r \vec{u} ) + \partial_r ( z_r \dot{r} ) &= 0 \\ - \partial_t z_r \theta + \nabla_r \cdot ( z_r \vec{u} \theta ) + \partial_r ( z_r \dot{r} \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t z_r S + \nabla_r \cdot ( z_r \vec{u} S ) + \partial_r ( z_r \dot{r} S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o}\boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdotp \boldsymbol{\underline{\tau}} ,\\ + \rho \partial_z \Phi + \partial_z p &= 0 ,\\ + \partial_t z_r + \boldsymbol{\nabla}_r \cdotp ( z_r \boldsymbol{u} ) + \partial_r ( z_r \dot{r} ) &= 0 ,\\ + \partial_t (z_r \theta) + \boldsymbol{\nabla}_r \cdotp ( z_r \boldsymbol{u} \theta ) + \partial_r ( z_r \dot{r} \theta ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_\theta ,\\ + \partial_t (z_r S) + \boldsymbol{\nabla}_r \cdotp ( z_r \boldsymbol{u} S ) + \partial_r ( z_r \dot{r} S ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) . diff --git a/docs/equations/governing.rst b/docs/equations/governing.rst index 4687b2f8fc..5b37e12118 100644 --- a/docs/equations/governing.rst +++ b/docs/equations/governing.rst @@ -6,39 +6,39 @@ Governing equations The Boussinesq hydrostatic equations of motion in height coordinates are .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \partial_z \Phi + \partial_z p &= 0 \\ - \nabla_z \cdot \vec{u} + \partial_z w &= 0 \\ - D_t \theta &= \nabla \cdot \vec{Q}_\theta \\ - D_t S &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) - -where notation is described in :ref:`equations-notation`. :math:`\vec{\underline{\tau}}` is the stress tensori and -:math:`\vec{Q}_\theta` and :math:`\vec{Q}_S` are fluxes of heat and salt respectively. + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o} \boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdotp \boldsymbol{\underline{\tau}} , \\ + \rho \partial_z \Phi + \partial_z p &= 0 , \\ + \boldsymbol{\nabla}_z \cdotp \boldsymbol{u} + \partial_z w &= 0 , \\ + D_t \theta &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_\theta , \\ + D_t S &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_S , \\ + \rho &= \rho(S, \theta, z) , + +where notation is described in :ref:`equations-notation`. :math:`\boldsymbol{\underline{\tau}}` is the stress tensori and +:math:`\boldsymbol{Q}_\theta` and :math:`\boldsymbol{Q}_S` are fluxes of heat and salt respectively. .. :ref:`vector_invariant` The total derivative is .. math:: - D_t &\equiv \partial_t + \vec{v} \cdot \nabla \\ - &= \partial_t + \vec{u} \cdot \nabla_z + w \partial_z + D_t & \equiv \partial_t + \boldsymbol{v} \cdotp \boldsymbol{\nabla} \\ + &= \partial_t + \boldsymbol{u} \cdotp \boldsymbol{\nabla}_z + w \partial_z . The non-divergence of flow allows a total derivative to be re-written in flux form: .. math:: - D_t \theta &= \partial_t + \nabla \cdot ( \vec{v} \theta ) \\ - &= \partial_t + \nabla_z \cdot ( \vec{u} \theta ) + \partial_z ( w \theta ) + D_t \theta &= \partial_t + \boldsymbol{\nabla} \cdotp ( \boldsymbol{v} \theta ) \\ + &= \partial_t + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} \theta ) + \partial_z ( w \theta ) . The above equations of motion can thus be written as: .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \partial_z \Phi + \partial_z p &= 0 \\ - \nabla_z \cdot \vec{u} + \partial_z w &= 0 \\ - \partial_t \theta + \nabla_z \cdot ( \vec{u} \theta ) + \partial_z ( w \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t S + \nabla_z \cdot ( \vec{u} S ) + \partial_z ( w S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o}\boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdotp \boldsymbol{\underline{\tau}} ,\\ + \rho \partial_z \Phi + \partial_z p &= 0 ,\\ + \boldsymbol{\nabla}_z \cdotp \boldsymbol{u} + \partial_z w &= 0 ,\\ + \partial_t \theta + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} \theta ) + \partial_z ( w \theta ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_\theta ,\\ + \partial_t S + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} S ) + \partial_z ( w S ) &= \nabla \cdotp \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) . .. toctree:: vector_invariant_eqns diff --git a/docs/equations/notation.rst b/docs/equations/notation.rst index e15cc204c9..17e320c131 100644 --- a/docs/equations/notation.rst +++ b/docs/equations/notation.rst @@ -16,28 +16,28 @@ Horizontal components of velocity are indicated by :math:`u` and :math:`v` and v :math:`p` is pressure and :math:`\Phi` is geo-potential: -.. math: - \Phi = g z +.. math:: + \Phi = g z . The thermodynamic state variables are usually salinity, :math:`S`, and potential temperature, :math:`\theta` or the absolute salinity and conservative temperature, depending on the equation of state. :math:`\rho` is in-situ density. Vector notation --------------- -The three-dimensional velocity vector is denoted :math:`\vec{v}` +The three-dimensional velocity vector is denoted :math:`\boldsymbol{v}` .. math:: - \vec{v} = \vec{u} + \vec{k} w + \boldsymbol{v} = \boldsymbol{u} + \widehat{\boldsymbol{k}} w , -where :math:`\vec{k}` is the unit vector pointed in the upward vertical direction and :math:`\vec{u} = (u,v,0)` is the horizontal +where :math:`\widehat{\boldsymbol{k}}` is the unit vector pointed in the upward vertical direction and :math:`\boldsymbol{u} = (u, v, 0)` is the horizontal component of velocity normal to the vertical. The gradient operator without a suffix is three dimensional: .. math:: - \nabla = ( \nabla_z, \partial_z ) . + \boldsymbol{\nabla} = ( \boldsymbol{\nabla}_z, \partial_z ) . but a suffix indicates a lateral gradient along a surface of constant property indicated by the suffix: .. math:: - \nabla_z = \left( \left. \partial_x \right|_z, \left. \partial_y \right|_z, 0 \right) . + \boldsymbol{\nabla}_z = \left( \left. \partial_x \right|_z, \left. \partial_y \right|_z, 0 \right) . diff --git a/docs/equations/overview.rst b/docs/equations/overview.rst index b6f8d60627..de7a4e484d 100644 --- a/docs/equations/overview.rst +++ b/docs/equations/overview.rst @@ -4,7 +4,7 @@ Equations The model equations are the layer-integrated vector-invariant form of the hydrostatic primitive equations (either Boussinesq or non-Boussinesq). -We present the equations starting from the hydrostatic Boussinesq equation is +We present the equations starting from the hydrostatic Boussinesq equation in height coordinates and progress through vector-invariant and general-coordinate equations to the final equations used in the A.L.E. algorithm. diff --git a/docs/equations/vector_invariant_eqns.rst b/docs/equations/vector_invariant_eqns.rst index 22c3b10ee1..f57eb8bafa 100644 --- a/docs/equations/vector_invariant_eqns.rst +++ b/docs/equations/vector_invariant_eqns.rst @@ -3,23 +3,23 @@ Vector Invariant Equations ========================== -MOM6 solve the momentum equations written in vector-invariant form. +MOM6 solves the momentum equations written in vector-invariant form. -An identity allows the total derivative of velocity to be written in the vector-invariant form: +A vector identity allows the total derivative of velocity to be written in the vector-invariant form: .. math:: - D_t \vec{u} &= \partial_t \vec{u} + \vec{v} \cdot \nabla \vec{u} \\ - &= \partial_t \vec{u} + \vec{u} \cdot \nabla_z \vec{u} + w \partial_z \vec{u} \\ - &= \partial_t \vec{u} + \left( \nabla \wedge \vec{u} \right) \wedge \vec{v} + \nabla \frac{1}{2} \left|\vec{u}\right|^2 + D_t \boldsymbol{u} &= \partial_t \boldsymbol{u} + \boldsymbol{v} \cdotp \boldsymbol{\nabla} \boldsymbol{u} \\ + &= \partial_t \boldsymbol{u} + \boldsymbol{u} \cdotp \boldsymbol{\nabla}_z \boldsymbol{u} + w \partial_z \boldsymbol{u} \\ + &= \partial_t \boldsymbol{u} + \left( \boldsymbol{\nabla} \wedge \boldsymbol{u} \right) \wedge \boldsymbol{v} + \boldsymbol{\nabla} \underbrace{\frac{1}{2} \left|\boldsymbol{u}\right|^2}_{\equiv K} . The flux-form equations of motion in height coordinates can thus be written succinctly as: .. math:: - \partial_t \vec{u} + \left( f \hat{k} + \nabla \wedge \vec{u} \right) \wedge \vec{v} + \nabla K - + \frac{\rho}{\rho_o} \nabla \Phi + \frac{1}{\rho_o} \nabla p &= \nabla \cdot \vec{\underline{\tau}} \\ - \nabla_z \cdot \vec{u} + \partial_z w &= 0 \\ - \partial_t \theta + \nabla_z \cdot ( \vec{u} \theta ) + \partial_z ( w \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t S + \nabla_z \cdot ( \vec{u} S ) + \partial_z ( w S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + \partial_t \boldsymbol{u} + \left( f \widehat{\boldsymbol{k}} + \boldsymbol{\nabla} \wedge \boldsymbol{u} \right) \wedge \boldsymbol{v} + \boldsymbol{\nabla} K + + \frac{\rho}{\rho_o} \boldsymbol{\nabla} \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla} p &= \boldsymbol{\nabla} \cdotp \boldsymbol{\underline{\tau}} ,\\ + \boldsymbol{\nabla}_z \cdotp \boldsymbol{u} + \partial_z w &= 0 ,\\ + \partial_t \theta + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} \theta ) + \partial_z ( w \theta ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_\theta ,\\ + \partial_t S + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} S ) + \partial_z ( w S ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) , where the horizontal momentum equations and vertical hydrostatic balance equation have been written as a single three-dimensional equation. diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index f6c84dff5a..b9aedb7a1c 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -161,8 +161,8 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "REMAP_UV_USING_OLD_ALG", & CS%remap_uv_using_old_alg, & - "If true, uses the old remapping-via-a-delta-z method for\n"//& - "remapping u and v. If false, uses the new method that remaps\n"//& + "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.", & default=.true.) @@ -171,24 +171,24 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) ! Initialize and configure remapping call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & - "This sets the reconstruction scheme used\n"//& - "for vertical remapping for all variables.\n"//& - "It can be one of the following schemes:\n"//& + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & - "If true, cell-by-cell reconstructions are checked for\n"//& - "consistency and if non-monotonicty or an inconsistency is\n"//& + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.) call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & - "If true, the results of remapping are checked for\n"//& - "conservation and new extrema and if an inconsistency is\n"//& + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.) call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & - "If true, the values on the intermediate grid used for remapping\n"//& - "are forced to be bounded, which might not be the case due to\n"//& + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& "round off.", default=.false.) call get_param(param_file, mdl, "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & - "If true, values at the interfaces of boundary cells are \n"//& + "If true, values at the interfaces of boundary cells are "//& "extrapolated instead of piecewise constant", default=.false.) call initialize_remapping( CS%remapCS, string, & boundary_extrapolation=remap_boundary_extrap, & @@ -197,32 +197,32 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) force_bounds_in_subcell=force_bounds_in_subcell) call get_param(param_file, mdl, "REMAP_AFTER_INITIALIZATION", CS%remap_after_initialization, & - "If true, applies regridding and remapping immediately after\n"//& - "initialization so that the state is ALE consistent. This is a\n"//& - "legacy step and should not be needed if the initialization is\n"//& + "If true, applies regridding and remapping immediately after "//& + "initialization so that the state is ALE consistent. This is a "//& + "legacy step and should not be needed if the initialization is "//& "consistent with the coordinate mode.", default=.true.) call get_param(param_file, mdl, "REGRID_TIME_SCALE", CS%regrid_time_scale, & - "The time-scale used in blending between the current (old) grid\n"//& - "and the target (new) grid. A short time-scale favors the target\n"//& - "grid (0. or anything less than DT_THERM) has no memory of the old\n"//& + "The time-scale used in blending between the current (old) grid "//& + "and the target (new) grid. A short time-scale favors the target "//& + "grid (0. or anything less than DT_THERM) has no memory of the old "//& "grid. A very long time-scale makes the model more Lagrangian.", & units="s", default=0.) call get_param(param_file, mdl, "REGRID_FILTER_SHALLOW_DEPTH", filter_shallow_depth, & - "The depth above which no time-filtering is applied. Above this depth\n"//& + "The depth above which no time-filtering is applied. Above this depth "//& "final grid exactly matches the target (new) grid.", & units="m", default=0., scale=GV%m_to_H) call get_param(param_file, mdl, "REGRID_FILTER_DEEP_DEPTH", filter_deep_depth, & - "The depth below which full time-filtering is applied with time-scale\n"//& - "REGRID_TIME_SCALE. Between depths REGRID_FILTER_SHALLOW_DEPTH and\n"//& - "REGRID_FILTER_SHALLOW_DEPTH the filter wieghts adopt a cubic profile.", & + "The depth below which full time-filtering is applied with time-scale "//& + "REGRID_TIME_SCALE. Between depths REGRID_FILTER_SHALLOW_DEPTH and "//& + "REGRID_FILTER_SHALLOW_DEPTH the filter weights adopt a cubic profile.", & units="m", default=0., scale=GV%m_to_H) call set_regrid_params(CS%regridCS, depth_of_time_filter_shallow=filter_shallow_depth, & depth_of_time_filter_deep=filter_deep_depth) call get_param(param_file, mdl, "REGRID_USE_OLD_DIRECTION", local_logical, & - "If true, the regridding ntegrates upwards from the bottom for\n"//& - "interface positions, much as the main model does. If false\n"//& - "regridding integrates downward, consistant with the remapping\n"//& + "If true, the regridding ntegrates upwards from the bottom for "//& + "interface positions, much as the main model does. If false "//& + "regridding integrates downward, consistant with the remapping "//& "code.", default=.true., do_not_log=.true.) call set_regrid_params(CS%regridCS, integrate_downward_for_e=.not.local_logical) @@ -1121,8 +1121,8 @@ subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS) character(len=30) :: coord_mode call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", coord_mode, & - "Coordinate mode for vertical regridding.\n"//& - "Choose among the following possibilities:\n"//& + "Coordinate mode for vertical regridding. "//& + "Choose among the following possibilities: "//& trim(regriddingCoordinateModeDoc), & default=DEFAULT_COORDINATE_MODE, fail_if_missing=.true.) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 2a1bcd5bcb..bb171aba7a 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -140,8 +140,8 @@ module MOM_regridding !> Documentation for coordinate options character(len=*), parameter, public :: regriddingCoordinateModeDoc = & " LAYER - Isopycnal or stacked shallow water layers\n"//& - " ZSTAR, Z* - stetched geopotential z*\n"//& - " SIGMA_SHELF_ZSTAR - stetched geopotential z* ignoring shelf\n"//& + " ZSTAR, Z* - stretched geopotential z*\n"//& + " SIGMA_SHELF_ZSTAR - stretched geopotential z* ignoring shelf\n"//& " SIGMA - terrain following coordinates\n"//& " RHO - continuous isopycnal\n"//& " HYCOM1 - HyCOM-like hybrid coordinate\n"//& @@ -230,8 +230,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (main_parameters) then ! Read coordinate units parameter (main model = REGRIDDING_COORDINATE_UNITS) call get_param(param_file, mdl, "REGRIDDING_COORDINATE_UNITS", coord_units, & - "Units of the regridding coordinuate.",& !### Spelling error "coordinuate" - default=coordinateUnits(coord_mode)) + "Units of the regridding coordinate.", default=coordinateUnits(coord_mode)) else coord_units=coordinateUnits(coord_mode) endif @@ -245,21 +244,21 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m string2 = 'PPM_H4' ! Default for diagnostics endif call get_param(param_file, mdl, "INTERPOLATION_SCHEME", string, & - "This sets the interpolation scheme to use to\n"//& - "determine the new grid. These parameters are\n"//& - "only relevant when REGRIDDING_COORDINATE_MODE is\n"//& - "set to a function of state. Otherwise, it is not\n"//& - "used. It can be one of the following schemes:\n"//& + "This sets the interpolation scheme to use to "//& + "determine the new grid. These parameters are "//& + "only relevant when REGRIDDING_COORDINATE_MODE is "//& + "set to a function of state. Otherwise, it is not "//& + "used. It can be one of the following schemes: "//& trim(regriddingInterpSchemeDoc), default=trim(string2)) call set_regrid_params(CS, interp_scheme=string) endif if (main_parameters .and. coord_is_state_dependent) then call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", tmpLogical, & - "When defined, a proper high-order reconstruction\n"//& - "scheme is used within boundary cells rather\n"//& - "than PCM. E.g., if PPM is used for remapping, a\n"//& - "PPM reconstruction will also be used within\n"//& + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& + "PPM reconstruction will also be used within "//& "boundary cells.", default=regriddingDefaultBoundaryExtrapolation) call set_regrid_params(CS, boundary_extrapolation=tmpLogical) else @@ -278,7 +277,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (maximum_depth>3000.) string2='WOA09' ! For convenience endif call get_param(param_file, mdl, param_name, string, & - "Determines how to specify the coordinate\n"//& + "Determines how to specify the coordinate "//& "resolution. Valid options are:\n"//& " PARAM - use the vector-parameter "//trim(coord_res_param)//"\n"//& " UNIFORM[:N] - uniformly distributed\n"//& @@ -420,7 +419,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target, & - 'HYBRID target densities for itnerfaces', units=coordinateUnits(coord_mode)) + 'HYBRID target densities for interfaces', units=coordinateUnits(coord_mode)) endif elseif (index(trim(string),'WOA09')==1) then if (len_trim(string)==5) then @@ -502,15 +501,15 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (main_parameters .and. coord_is_state_dependent) then call get_param(param_file, mdl, "REGRID_COMPRESSIBILITY_FRACTION", tmpReal, & - "When interpolating potential density profiles we can add\n"//& - "some artificial compressibility solely to make homogenous\n"//& + "When interpolating potential density profiles we can add "//& + "some artificial compressibility solely to make homogeneous "//& "regions appear stratified.", default=0.) call set_regrid_params(CS, compress_fraction=tmpReal) endif if (main_parameters) then call get_param(param_file, mdl, "MIN_THICKNESS", tmpReal, & - "When regridding, this is the minimum layer\n"//& + "When regridding, this is the minimum layer "//& "thickness allowed.", units="m", scale=GV%m_to_H, & default=regriddingDefaultMinThickness ) call set_regrid_params(CS, min_thickness=tmpReal) @@ -521,23 +520,23 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (coordinateMode(coord_mode) == REGRIDDING_SLIGHT) then ! Set SLight-specific regridding parameters. call get_param(param_file, mdl, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & - "The nominal thickness of fixed thickness near-surface\n"//& + "The nominal thickness of fixed thickness near-surface "//& "layers with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) call get_param(param_file, mdl, "SLIGHT_NZ_SURFACE_FIXED", nz_fixed_sfc, & - "The number of fixed-depth surface layers with the SLight\n"//& + "The number of fixed-depth surface layers with the SLight "//& "coordinate.", units="nondimensional", default=2) call get_param(param_file, mdl, "SLIGHT_SURFACE_AVG_DEPTH", Rho_avg_depth, & - "The thickness of the surface region over which to average\n"//& - "when calculating the density to use to define the interior\n"//& + "The thickness of the surface region over which to average "//& + "when calculating the density to use to define the interior "//& "with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) call get_param(param_file, mdl, "SLIGHT_NLAY_TO_INTERIOR", nlay_sfc_int, & - "The number of layers to offset the surface density when\n"//& + "The number of layers to offset the surface density when "//& "defining where the interior ocean starts with SLight.", & units="nondimensional", default=2.0) call get_param(param_file, mdl, "SLIGHT_FIX_HALOCLINES", fix_haloclines, & - "If true, identify regions above the reference pressure\n"//& - "where the reference pressure systematically underestimates\n"//& - "the stratification and use this in the definition of the\n"//& + "If true, identify regions above the reference pressure "//& + "where the reference pressure systematically underestimates "//& + "the stratification and use this in the definition of the "//& "interior with the SLight coordinate.", default=.false.) call set_regrid_params(CS, dz_min_surface=dz_fixed_sfc, & @@ -546,14 +545,14 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (fix_haloclines) then ! Set additional parameters related to SLIGHT_FIX_HALOCLINES. call get_param(param_file, mdl, "HALOCLINE_FILTER_LENGTH", filt_len, & - "A length scale over which to smooth the temperature and\n"//& + "A length scale over which to smooth the temperature and "//& "salinity before identifying erroneously unstable haloclines.", & units="m", default=2.0) call get_param(param_file, mdl, "HALOCLINE_STRAT_TOL", strat_tol, & - "A tolerance for the ratio of the stratification of the\n"//& - "apparent coordinate stratification to the actual value\n"//& - "that is used to identify erroneously unstable haloclines.\n"//& - "This ratio is 1 when they are equal, and sensible values \n"//& + "A tolerance for the ratio of the stratification of the "//& + "apparent coordinate stratification to the actual value "//& + "that is used to identify erroneously unstable haloclines. "//& + "This ratio is 1 when they are equal, and sensible values "//& "are between 0 and 0.5.", units="nondimensional", default=0.2) call set_regrid_params(CS, halocline_filt_len=filt_len, & halocline_strat_tol=strat_tol) @@ -576,7 +575,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "Scaling on optimization tendency.", & units="nondim", default=1.0) call get_param(param_file, mdl, "ADAPT_DO_MIN_DEPTH", tmpLogical, & - "If true, make a HyCOM-like mixed layer by preventing interfaces\n"//& + "If true, make a HyCOM-like mixed layer by preventing interfaces "//& "from being shallower than the depths specified by the regridding coordinate.", & default=.false.) diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 452b3dfa09..74af5813eb 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -286,7 +286,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ zInterface(1) = 0. do k = 1,nz zInterface(k+1) = zInterface(k) - h1(k) - ! Adjust interface position to accomodate inflating layers + ! Adjust interface position to accommodate inflating layers ! without disturbing the interface above enddo else @@ -294,7 +294,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ zInterface(nz+1) = -depth do k = nz,1,-1 zInterface(k) = zInterface(k+1) + h1(k) - ! Adjust interface position to accomodate inflating layers + ! Adjust interface position to accommodate inflating layers ! without disturbing the interface above enddo endif diff --git a/src/ALE/coord_sigma.F90 b/src/ALE/coord_sigma.F90 index 3bf666ec52..19c3213996 100644 --- a/src/ALE/coord_sigma.F90 +++ b/src/ALE/coord_sigma.F90 @@ -72,7 +72,7 @@ subroutine build_sigma_column(CS, depth, totalThickness, zInterface) zInterface(CS%nk+1) = -depth do k = CS%nk,1,-1 zInterface(k) = zInterface(k+1) + (totalThickness * CS%coordinateResolution(k)) - ! Adjust interface position to accomodate inflating layers + ! Adjust interface position to accommodate inflating layers ! without disturbing the interface above if (zInterface(k) < (zInterface(k+1) + CS%min_thickness)) then zInterface(k) = zInterface(k+1) + CS%min_thickness diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index aa684f1f26..13a6cf2f1f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -727,8 +727,13 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & !=========================================================================== ! This is the second place where the diabatic processes and remapping could occur. - if (CS%t_dyn_rel_adv == 0.0 .and. do_thermo .and. .not.CS%diabatic_first) then + if ((CS%t_dyn_rel_adv==0.0) .and. do_thermo .and. (.not.CS%diabatic_first)) then + dtdia = CS%t_dyn_rel_thermo + ! If the MOM6 dynamic and thermodynamic time stepping is being orchestrated + ! by the coupler, the value of diabatic_first does not matter. + if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) dtdia = dt + if (CS%thermo_spans_coupling .and. (CS%dt_therm > 1.5*cycle_time) .and. & (abs(dt_therm - dtdia) > 1e-6*dt_therm)) then call MOM_error(FATAL, "step_MOM: Mismatch between dt_therm and dtdia "//& @@ -739,7 +744,13 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & Time_local, .false., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia - CS%t_dyn_rel_thermo = 0.0 + + if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then + ! The diabatic processes are now ahead of the dynamics by dtdia. + CS%t_dyn_rel_thermo = -dtdia + else ! The diabatic processes and the dynamics are synchronized. + CS%t_dyn_rel_thermo = 0.0 + endif endif @@ -1492,7 +1503,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & count_calls, tracer_flow_CSp) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar - type(param_file_type), intent(out) :: param_file !< structure indicating paramater file to parse + type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse type(directories), intent(out) :: dirs !< structure with directory paths type(MOM_control_struct), pointer :: CS !< pointer set in this routine to MOM control structure type(MOM_restart_CS), pointer :: restart_CSp !< pointer set in this routine to the @@ -1638,86 +1649,86 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif call get_param(param_file, "MOM", "CALC_RHO_FOR_SEA_LEVEL", CS%calc_rho_for_sea_lev, & - "If true, the in-situ density is used to calculate the\n"//& - "effective sea level that is returned to the coupler. If false,\n"//& + "If true, the in-situ density is used to calculate the "//& + "effective sea level that is returned to the coupler. If false, "//& "the Boussinesq parameter RHO_0 is used.", default=.false.) call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, "MOM", "USE_EOS", use_EOS, & - "If true, density is calculated from temperature and \n"//& - "salinity with an equation of state. If USE_EOS is \n"//& + "If true, density is calculated from temperature and "//& + "salinity with an equation of state. If USE_EOS is "//& "true, ENABLE_THERMODYNAMICS must be true as well.", & default=use_temperature) call get_param(param_file, "MOM", "DIABATIC_FIRST", CS%diabatic_first, & - "If true, apply diabatic and thermodynamic processes, \n"//& - "including buoyancy forcing and mass gain or loss, \n"//& + "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, "MOM", "USE_CONTEMP_ABSSAL", use_conT_absS, & - "If true, the prognostics T&S are the conservative temperature \n"//& - "and absolute salinity. Care should be taken to convert them \n"//& - "to potential temperature and practical salinity before \n"//& - "exchanging them with the coupler and/or reporting T&S diagnostics.\n", & + "If true, the prognostics T&S are the conservative temperature "//& + "and absolute salinity. Care should be taken to convert them "//& + "to potential temperature and practical salinity before "//& + "exchanging them with the coupler and/or reporting T&S diagnostics.", & default=.false.) CS%tv%T_is_conT = use_conT_absS ; CS%tv%S_is_absS = use_conT_absS call get_param(param_file, "MOM", "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is \n"//& - "true. This assumes that KD = KDML = 0.0 and that \n"//& - "there is no buoyancy forcing, but makes the model \n"//& + "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, "MOM", "USE_LEGACY_DIABATIC_DRIVER", CS%use_legacy_diabatic_driver, & - "If true, use a legacy version of the diabatic subroutine. \n"//& + "If true, use a legacy version of the diabatic subroutine. "//& "This is temporary and is needed to avoid change in answers.", & default=.true.) call get_param(param_file, "MOM", "DO_DYNAMICS", CS%do_dynamics, & - "If False, skips the dynamics calls that update u & v, as well as \n"//& - "the gravity wave adjustment to h. This is a fragile feature and \n"//& + "If False, skips the dynamics calls that update u & v, as well as "//& + "the gravity wave adjustment to h. This is a fragile feature and "//& "thus undocumented.", default=.true., do_not_log=.true. ) call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & - "If True, advect temperature and salinity horizontally \n"//& - "If False, T/S are registered for advection.\n"//& - "This is intended only to be used in offline tracer mode \n"//& + "If True, advect temperature and salinity horizontally "//& + "If False, T/S are registered for advection. "//& + "This is intended only to be used in offline tracer mode "//& "and is by default false in that case.", & do_not_log = .true., default=.true. ) if (present(offline_tracer_mode)) then ! Only read this parameter in enabled modes call get_param(param_file, "MOM", "OFFLINE_TRACER_MODE", CS%offline_tracer_mode, & - "If true, barotropic and baroclinic dynamics, thermodynamics\n"//& - "are all bypassed with all the fields necessary to integrate\n"//& - "the tracer advection and diffusion equation are read in from\n"//& - "files stored from a previous integration of the prognostic model.\n"//& + "If true, barotropic and baroclinic dynamics, thermodynamics "//& + "are all bypassed with all the fields necessary to integrate "//& + "the tracer advection and diffusion equation are read in from "//& + "files stored from a previous integration of the prognostic model. "//& "NOTE: This option only used in the ocean_solo_driver.", default=.false.) if (CS%offline_tracer_mode) then call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & - "If True, advect temperature and salinity horizontally\n"//& - "If False, T/S are registered for advection.\n"//& + "If True, advect temperature and salinity horizontally "//& + "If False, T/S are registered for advection. "//& "This is intended only to be used in offline tracer mode."//& "and is by default false in that case", & default=.false. ) endif endif call get_param(param_file, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm, & - "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, "MOM", "BULKMIXEDLAYER", bulkmixedlayer, & - "If true, use a Kraus-Turner-like bulk mixed layer \n"//& - "with transitional buffer layers. Layers 1 through \n"//& - "NKML+NKBL have variable densities. There must be at \n"//& - "least NKML+NKBL+1 layers if BULKMIXEDLAYER is true. \n"//& - "BULKMIXEDLAYER can not be used with USE_REGRIDDING. \n"//& + "If true, use a Kraus-Turner-like bulk mixed layer "//& + "with transitional buffer layers. Layers 1 through "//& + "NKML+NKBL have variable densities. There must be at "//& + "least NKML+NKBL+1 layers if BULKMIXEDLAYER is true. "//& + "BULKMIXEDLAYER can not be used with USE_REGRIDDING. "//& "The default is influenced by ENABLE_THERMODYNAMICS.", & default=use_temperature .and. .not.CS%use_ALE_algorithm) call get_param(param_file, "MOM", "THICKNESSDIFFUSE", CS%thickness_diffuse, & - "If true, interface heights are diffused with a \n"//& + "If true, interface heights are diffused with a "//& "coefficient of KHTH.", default=.false.) call get_param(param_file, "MOM", "THICKNESSDIFFUSE_FIRST", & CS%thickness_diffuse_first, & - "If true, do thickness diffusion before dynamics.\n"//& + "If true, do thickness diffusion before dynamics. "//& "This is only used if THICKNESSDIFFUSE is true.", & default=.false.) if (.not.CS%thickness_diffuse) CS%thickness_diffuse_first = .false. call get_param(param_file, "MOM", "BATHYMETRY_AT_VEL", bathy_at_vel, & - "If true, there are separate values for the basin depths \n"//& - "at velocity points. Otherwise the effects of topography \n"//& + "If true, there are separate values for the basin depths "//& + "at velocity points. Otherwise the effects of topography "//& "are entirely determined from thickness points.", & default=.false.) call get_param(param_file, "MOM", "USE_WAVES", CS%UseWaves, default=.false., & @@ -1727,56 +1738,56 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) call get_param(param_file, "MOM", "DEBUG_TRUNCATIONS", debug_truncations, & - "If true, calculate all diagnostics that are useful for \n"//& + "If true, calculate all diagnostics that are useful for "//& "debugging truncations.", default=.false., debuggingParam=.true.) call get_param(param_file, "MOM", "DT", CS%dt, & - "The (baroclinic) dynamics time step. The time-step that \n"//& - "is actually used will be an integer fraction of the \n"//& - "forcing time-step (DT_FORCING in ocean-only mode or the \n"//& + "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.)", units="s", & fail_if_missing=.true.) call get_param(param_file, "MOM", "DT_THERM", CS%dt_therm, & - "The thermodynamic and tracer advection time step. \n"//& - "Ideally DT_THERM should be an integer multiple of DT \n"//& - "and less than the forcing or coupling time-step, unless \n"//& - "THERMO_SPANS_COUPLING is true, in which case DT_THERM \n"//& - "can be an integer multiple of the coupling timestep. By \n"//& + "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=CS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", CS%thermo_spans_coupling, & - "If true, the MOM will take thermodynamic and tracer \n"//& - "timesteps that can be longer than the coupling timestep. \n"//& - "The actual thermodynamic timestep that is used in this \n"//& - "case is the largest integer multiple of the coupling \n"//& + "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.) if (bulkmixedlayer) then CS%Hmix = -1.0 ; CS%Hmix_UV = -1.0 else call get_param(param_file, "MOM", "HMIX_SFC_PROP", CS%Hmix, & - "If BULKMIXEDLAYER is false, HMIX_SFC_PROP is the depth \n"//& - "over which to average to find surface properties like \n"//& + "If BULKMIXEDLAYER is false, HMIX_SFC_PROP is the depth "//& + "over which to average to find surface properties like "//& "SST and SSS or density (but not surface velocities).", & units="m", default=1.0, scale=US%m_to_Z) call get_param(param_file, "MOM", "HMIX_UV_SFC_PROP", CS%Hmix_UV, & - "If BULKMIXEDLAYER is false, HMIX_UV_SFC_PROP is the depth\n"//& - "over which to average to find surface flow properties,\n"//& + "If BULKMIXEDLAYER is false, HMIX_UV_SFC_PROP is the depth "//& + "over which to average to find surface flow properties, "//& "SSU, SSV. A non-positive value indicates no averaging.", & units="m", default=0.0, scale=US%m_to_Z) endif call get_param(param_file, "MOM", "HFREEZE", CS%HFrz, & - "If HFREEZE > 0, melt potential will be computed. The actual depth \n"//& - "over which melt potential is computed will be min(HFREEZE, OBLD), \n"//& - "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), \n"//& + "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) call get_param(param_file, "MOM", "MIN_Z_DIAG_INTERVAL", Z_diag_int, & - "The minimum amount of time in seconds between \n"//& - "calculations of depth-space diagnostics. Making this \n"//& - "larger than DT_THERM reduces the performance penalty \n"//& + "The minimum amount of time in seconds between "//& + "calculations of depth-space diagnostics. Making this "//& + "larger than DT_THERM reduces the performance penalty "//& "of regridding to depth online.", units="s", default=0.0) call get_param(param_file, "MOM", "INTERPOLATE_P_SURF", CS%interp_p_surf, & - "If true, linearly interpolate the surface pressure \n"//& - "over the coupling time step, using the specified value \n"//& + "If true, linearly interpolate the surface pressure "//& + "over the coupling time step, using the specified value "//& "at the end of the step.", default=.false.) if (CS%split) then @@ -1784,10 +1795,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & default_val = CS%dt_therm ; if (dtbt > 0.0) default_val = -1.0 CS%dtbt_reset_period = -1.0 call get_param(param_file, "MOM", "DTBT_RESET_PERIOD", CS%dtbt_reset_period, & - "The period between recalculations of DTBT (if DTBT <= 0). \n"//& - "If DTBT_RESET_PERIOD is negative, DTBT is set based \n"//& - "only on information available at initialization. If 0, \n"//& - "DTBT will be set every dynamics time step. The default \n"//& + "The period between recalculations of DTBT (if DTBT <= 0). "//& + "If DTBT_RESET_PERIOD is negative, DTBT is set based "//& + "only on information available at initialization. If 0, "//& + "DTBT will be set every dynamics time step. The default "//& "is set by DT_THERM. This is only used if SPLIT is true.", & units="s", default=default_val, do_not_read=(dtbt > 0.0)) endif @@ -1796,42 +1807,46 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & use_frazil = .false. ; bound_salinity = .false. ; CS%tv%P_Ref = 2.0e7 if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & - "If true, water freezes if it gets too cold, and the \n"//& - "the accumulated heat deficit is returned in the \n"//& - "surface state. FRAZIL is only used if \n"//& + "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.", default=.false.) call get_param(param_file, "MOM", "DO_GEOTHERMAL", use_geothermal, & "If true, apply geothermal heating.", default=.false.) call get_param(param_file, "MOM", "BOUND_SALINITY", bound_salinity, & - "If true, limit salinity to being positive. (The sea-ice \n"//& - "model may ask for more salt than is available and \n"//& + "If true, limit salinity to being positive. (The sea-ice "//& + "model may ask for more salt than is available and "//& "drive the salinity negative otherwise.)", default=.false.) + call get_param(param_file, "MOM", "MIN_SALINITY", CS%tv%min_salinity, & + "The minimum value of salinity when BOUND_SALINITY=True. "//& + "The default is 0.01 for backward compatibility but ideally "//& + "should be 0.", units="PPT", default=0.01, do_not_log=.not.bound_salinity) call get_param(param_file, "MOM", "C_P", CS%tv%C_p, & - "The heat capacity of sea water, approximated as a \n"//& - "constant. This is only used if ENABLE_THERMODYNAMICS is \n"//& - "true. The default value is from the TEOS-10 definition \n"//& + "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.", units="J kg-1 K-1", & default=3991.86795711963) endif if (use_EOS) call get_param(param_file, "MOM", "P_REF", CS%tv%P_Ref, & - "The pressure that is used for calculating the coordinate \n"//& - "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) \n"//& - "This is only used if USE_EOS and ENABLE_THERMODYNAMICS \n"//& + "The pressure that is used for calculating the coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS "//& "are true.", units="Pa", default=2.0e7) if (bulkmixedlayer) then call get_param(param_file, "MOM", "NKML", nkml, & - "The number of sublayers within the mixed layer if \n"//& + "The number of sublayers within the mixed layer if "//& "BULKMIXEDLAYER is true.", units="nondim", default=2) call get_param(param_file, "MOM", "NKBL", nkbl, & - "The number of layers that are used as variable density \n"//& + "The number of layers that are used as variable density "//& "buffer layers if BULKMIXEDLAYER is true.", units="nondim", & default=2) endif call get_param(param_file, "MOM", "GLOBAL_INDEXING", global_indexing, & - "If true, use a global lateral indexing convention, so \n"//& - "that corresponding points on different processors have \n"//& + "If true, use a global lateral indexing convention, so "//& + "that corresponding points on different processors have "//& "the same index. This does not work with static memory.", & default=.false., layoutParam=.true.) #ifdef STATIC_MEMORY_ @@ -1839,9 +1854,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "GLOBAL_INDEXING can not be true with STATIC_MEMORY.") #endif call get_param(param_file, "MOM", "FIRST_DIRECTION", first_direction, & - "An integer that indicates which direction goes first \n"//& - "in parts of the code that use directionally split \n"//& - "updates, with even numbers (or 0) used for x- first \n"//& + "An integer that indicates which direction goes first "//& + "in parts of the code that use directionally split "//& + "updates, with even numbers (or 0) used for x- first "//& "and odd numbers used for y-first.", default=0) call get_param(param_file, "MOM", "CHECK_BAD_SURFACE_VALS", CS%check_bad_sfc_vals, & @@ -1849,37 +1864,37 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & default=.false.) if (CS%check_bad_sfc_vals) then call get_param(param_file, "MOM", "BAD_VAL_SSH_MAX", CS%bad_val_ssh_max, & - "The value of SSH above which a bad value message is \n"//& + "The value of SSH above which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & default=20.0) call get_param(param_file, "MOM", "BAD_VAL_SSS_MAX", CS%bad_val_sss_max, & - "The value of SSS above which a bad value message is \n"//& + "The value of SSS above which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="PPT", & default=45.0) call get_param(param_file, "MOM", "BAD_VAL_SST_MAX", CS%bad_val_sst_max, & - "The value of SST above which a bad value message is \n"//& + "The value of SST above which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", & units="deg C", default=45.0) call get_param(param_file, "MOM", "BAD_VAL_SST_MIN", CS%bad_val_sst_min, & - "The value of SST below which a bad value message is \n"//& + "The value of SST below which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", & units="deg C", default=-2.1) call get_param(param_file, "MOM", "BAD_VAL_COLUMN_THICKNESS", CS%bad_val_col_thick, & - "The value of column thickness below which a bad value message is \n"//& + "The value of column thickness below which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & default=0.0) endif call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, & - "If true, write the initial conditions to a file given \n"//& + "If true, write the initial conditions to a file given "//& "by IC_OUTPUT_FILE.", default=.false.) call get_param(param_file, "MOM", "IC_OUTPUT_FILE", CS%IC_file, & "The file into which to write the initial conditions.", & default="MOM_IC") call get_param(param_file, "MOM", "WRITE_GEOM", write_geom, & - "If =0, never write the geometry and vertical grid files.\n"//& - "If =1, write the geometry and vertical grid files only for\n"//& - "a new simulation. If =2, always write the geometry and\n"//& + "If =0, never write the geometry and vertical grid files. "//& + "If =1, write the geometry and vertical grid files only for "//& + "a new simulation. If =2, always write the geometry and "//& "vertical grid files. Other values are invalid.", default=1) if (write_geom<0 .or. write_geom>2) call MOM_error(FATAL,"MOM: "//& "WRITE_GEOM must be equal to 0, 1 or 2.") @@ -1919,9 +1934,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%ensemble_ocean=.false. call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, & - "If False, The model is being run in serial mode as a single realization.\n"//& - "If True, The current model realization is part of a larger ensemble \n"//& - "and at the end of step MOM, we will perform a gather of the ensemble\n"//& + "If False, The model is being run in serial mode as a single realization. "//& + "If True, The current model realization is part of a larger ensemble "//& + "and at the end of step MOM, we will perform a gather of the ensemble "//& "members for statistical evaluation and/or data assimilation.", default=.false.) call callTree_waypoint("MOM parameters read (initialize_MOM)") @@ -3386,7 +3401,7 @@ end subroutine MOM_end !! * src/tracer: !! These files handle the lateral transport and diffusion of !! tracers, or are the code to implement various passive tracer -!! packages. Additional tracer packages are readily accomodated. +!! packages. Additional tracer packages are readily accommodated. !! !! * src/user: !! These are either stub routines that a user could use to change diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 450d71d23e..a897e2af13 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -13,6 +13,7 @@ module MOM_CoriolisAdv use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_string_functions, only : uppercase +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : accel_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -107,7 +108,7 @@ module MOM_CoriolisAdv contains !> Calculates the Coriolis and momentum advection contributions to the acceleration. -subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) +subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocen grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [m s-1] @@ -122,8 +123,9 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: CAv !< Meridional acceleration due to Coriolis !! and momentum advection [m s-2]. type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(accel_diag_ptrs), intent(inout) :: AD !< Storage for acceleration diagnostics - type(CoriolisAdv_CS), pointer :: CS !< Control structure for MOM_CoriolisAdv + type(accel_diag_ptrs), intent(inout) :: AD !< Storage for acceleration diagnostics + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(CoriolisAdv_CS), pointer :: CS !< Control structure for MOM_CoriolisAdv ! Local variables real, dimension(SZIB_(G),SZJB_(G)) :: & @@ -410,7 +412,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) relative_vorticity = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * & G%IareaBu(I,J) endif - absolute_vorticity = G%CoriolisBu(I,J) + relative_vorticity + absolute_vorticity = US%s_to_T*G%CoriolisBu(I,J) + relative_vorticity Ih = 0.0 if (Area_q(i,j) > 0.0) then hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J)) @@ -949,23 +951,23 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & - "If true, no slip boundary conditions are used; otherwise \n"//& - "free slip boundary conditions are assumed. The \n"//& - "implementation of the free slip BCs on a C-grid is much \n"//& - "cleaner than the no slip BCs. The use of free slip BCs \n"//& - "is strongly encouraged, and no slip BCs are not used with \n"//& + "If true, no slip boundary conditions are used; otherwise "//& + "free slip boundary conditions are assumed. The "//& + "implementation of the free slip BCs on a C-grid is much "//& + "cleaner than the no slip BCs. The use of free slip BCs "//& + "is strongly encouraged, and no slip BCs are not used with "//& "the biharmonic viscosity.", default=.false.) call get_param(param_file, mdl, "CORIOLIS_EN_DIS", CS%Coriolis_En_Dis, & - "If true, two estimates of the thickness fluxes are used \n"//& - "to estimate the Coriolis term, and the one that \n"//& + "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.", & default=.false.) ! Set %Coriolis_Scheme ! (Select the baseline discretization for the Coriolis term) call get_param(param_file, mdl, "CORIOLIS_SCHEME", tmpstr, & - "CORIOLIS_SCHEME selects the discretization for the \n"//& + "CORIOLIS_SCHEME selects the discretization for the "//& "Coriolis terms. Valid values are: \n"//& "\t SADOURNY75_ENERGY - Sadourny, 1975; energy cons. \n"//& "\t ARAKAWA_HSU90 - Arakawa & Hsu, 1990 \n"//& @@ -996,16 +998,16 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) end select if (CS%Coriolis_Scheme == AL_BLEND) then call get_param(param_file, mdl, "CORIOLIS_BLEND_WT_LIN", CS%wt_lin_blend, & - "A weighting value for the ratio of inverse thicknesses, \n"//& - "beyond which the blending between Sadourny Energy and \n"//& - "Arakawa & Hsu goes linearly to 0 when CORIOLIS_SCHEME \n"//& + "A weighting value for the ratio of inverse thicknesses, "//& + "beyond which the blending between Sadourny Energy and "//& + "Arakawa & Hsu goes linearly to 0 when CORIOLIS_SCHEME "//& "is ARAWAKA_LAMB_BLEND. This must be between 1 and 1e-16.", & units="nondim", default=0.125) call get_param(param_file, mdl, "CORIOLIS_BLEND_F_EFF_MAX", CS%F_eff_max_blend, & - "The factor by which the maximum effective Coriolis \n"//& - "acceleration from any point can be increased when \n"//& - "blending different discretizations with the \n"//& - "ARAKAWA_LAMB_BLEND Coriolis scheme. This must be \n"//& + "The factor by which the maximum effective Coriolis "//& + "acceleration from any point can be increased when "//& + "blending different discretizations with the "//& + "ARAKAWA_LAMB_BLEND Coriolis scheme. This must be "//& "greater than 2.0 (the max value for Sadourny energy).", & units="nondim", default=4.0) CS%wt_lin_blend = min(1.0, max(CS%wt_lin_blend,1e-16)) @@ -1013,16 +1015,16 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) "CORIOLIS_BLEND_F_EFF_MAX should be at least 2.") endif - mesg = "If true, the Coriolis terms at u-points are bounded by \n"//& - "the four estimates of (f+rv)v from the four neighboring \n"//& + mesg = "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." if (CS%Coriolis_En_Dis .and. (CS%Coriolis_Scheme == SADOURNY75_ENERGY)) then - mesg = trim(mesg)//" This option is \n"//& - "always effectively false with CORIOLIS_EN_DIS defined and \n"//& + mesg = trim(mesg)//" This option is "//& + "always effectively false with CORIOLIS_EN_DIS defined and "//& "CORIOLIS_SCHEME set to "//trim(SADOURNY75_ENERGY_STRING)//"." else - mesg = trim(mesg)//" This option would \n"//& - "have no effect on the SADOURNY Coriolis scheme if it \n"//& + mesg = trim(mesg)//" This option would "//& + "have no effect on the SADOURNY Coriolis scheme if it "//& "were possible to use centered difference thickness fluxes." endif call get_param(param_file, mdl, "BOUND_CORIOLIS", CS%bound_Coriolis, mesg, & @@ -1032,7 +1034,7 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) ! Set KE_Scheme (selects discretization of KE) call get_param(param_file, mdl, "KE_SCHEME", tmpstr, & - "KE_SCHEME selects the discretization for acceleration \n"//& + "KE_SCHEME selects the discretization for acceleration "//& "due to the kinetic energy gradient. Valid values are: \n"//& "\t KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV", & default=KE_ARAKAWA_STRING) @@ -1049,7 +1051,7 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) ! Set PV_Adv_Scheme (selects discretization of PV advection) call get_param(param_file, mdl, "PV_ADV_SCHEME", tmpstr, & - "PV_ADV_SCHEME selects the discretization for PV \n"//& + "PV_ADV_SCHEME selects the discretization for PV "//& "advection. Valid values are: \n"//& "\t PV_ADV_CENTERED - centered (aka Sadourny, 75) \n"//& "\t PV_ADV_UPWIND1 - upwind, first order", & diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 110963789b..183817bf42 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -117,13 +117,13 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_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, "ANALYTIC_FV_PGF", CS%Analytic_FV_PGF, & - "If true the pressure gradient forces are calculated \n"//& - "with a finite volume form that analytically integrates \n"//& - "the equations of state in pressure to avoid any \n"//& - "possibility of numerical thermobaric instability, as \n"//& + "If true the pressure gradient forces are calculated "//& + "with a finite volume form that analytically integrates "//& + "the equations of state in pressure to avoid any "//& + "possibility of numerical thermobaric instability, as "//& "described in Adcroft et al., O. Mod. (2008).", default=.true.) call get_param(param_file, mdl, "BLOCKED_ANALYTIC_FV_PGF", CS%blocked_AFV, & - "If true, used the blocked version of the ANALYTIC_FV_PGF \n"//& + "If true, used the blocked version of the ANALYTIC_FV_PGF "//& "code. The value of this parameter should not change answers.", & default=.false., do_not_log=.true., debuggingParam=.true.) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 09d3e64266..42c08b8364 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -842,9 +842,9 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ mdl = "MOM_PressureForce_Mont" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, "TIDES", CS%tides, & diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index a8fcae3596..e68a699b7a 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -810,36 +810,36 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C mdl = "MOM_PressureForce_AFV" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & - "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & - "If true, use mass weighting when interpolating T/S for\n"//& - "integrals near the bathymetry in AFV pressure gradient\n"//& + "If true, use mass weighting when interpolating T/S for "//& + "integrals near the bathymetry in AFV pressure gradient "//& "calculations.", default=.false.) call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & - "If True, use vertical reconstruction of T & S within\n"//& - "the integrals of the FV pressure gradient calculation.\n"//& - "If False, use the constant-by-layer algorithm.\n"//& + "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.", & default=use_ALE ) call get_param(param_file, mdl, "PRESSURE_RECONSTRUCTION_SCHEME", CS%Recon_Scheme, & - "Order of vertical reconstruction of T/S to use in the\n"//& - "integrals within the FV pressure gradient calculation."//& + "Order of vertical reconstruction of T/S to use in the "//& + "integrals within the FV pressure gradient calculation.\n"//& " 0: PCM or no reconstruction.\n"//& " 1: PLM reconstruction.\n"//& " 2: PPM reconstruction.", default=1) call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", CS%boundary_extrap, & - "If true, the reconstruction of T & S for pressure in \n"//& - "boundary cells is extrapolated, rather than using PCM \n"//& - "in these cells. If true, the same order polynomial is \n"//& + "If true, the reconstruction of T & S for pressure in "//& + "boundary cells is extrapolated, rather than using PCM "//& + "in these cells. If true, the same order polynomial is "//& "used as is used for the interior cells.", default=.true.) if (CS%tides) then diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index a675eebaf4..4b602373e7 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -802,36 +802,36 @@ subroutine PressureForce_blk_AFV_init(Time, G, GV, US, param_file, diag, CS, tid mdl = "MOM_PressureForce_blk_AFV" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & - "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & - "If true, use mass weighting when interpolating T/S for\n"//& - "integrals near the bathymetry in AFV pressure gradient\n"//& + "If true, use mass weighting when interpolating T/S for "//& + "integrals near the bathymetry in AFV pressure gradient "//& "calculations.", default=.false.) call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & - "If True, use vertical reconstruction of T & S within\n"//& - "the integrals of the FV pressure gradient calculation.\n"//& - "If False, use the constant-by-layer algorithm.\n"//& + "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.", & default=use_ALE ) call get_param(param_file, mdl, "PRESSURE_RECONSTRUCTION_SCHEME", CS%Recon_Scheme, & - "Order of vertical reconstruction of T/S to use in the\n"//& - "integrals within the FV pressure gradient calculation."//& + "Order of vertical reconstruction of T/S to use in the "//& + "integrals within the FV pressure gradient calculation.\n"//& " 0: PCM or no reconstruction.\n"//& " 1: PLM reconstruction.\n"//& " 2: PPM reconstruction.", default=1) call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", CS%boundary_extrap, & - "If true, the reconstruction of T & S for pressure in \n"//& - "boundary cells is extrapolated, rather than using PCM \n"//& - "in these cells. If true, the same order polynomial is \n"//& + "If true, the reconstruction of T & S for pressure in "//& + "boundary cells is extrapolated, rather than using PCM "//& + "in these cells. If true, the same order polynomial is "//& "used as is used for the interior cells.", default=.true.) if (CS%tides) then diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index cdc5ed0251..2f1eb68961 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -199,7 +199,7 @@ module MOM_barotropic !! update at the start of a call to btstep. The !! default is 1. logical :: BT_project_velocity !< If true, step the barotropic velocity first - !! and project out the velocity tendancy by 1+BEBT + !! 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 do a corrector @@ -821,7 +821,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do I=is-1,ie - q(I,J) = 0.25 * G%CoriolisBu(I,J) * & + q(I,J) = 0.25 * US%s_to_T*G%CoriolisBu(I,J) * & ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & ((G%areaT(i,j) * G%bathyT(i,j) + G%areaT(i+1,j+1) * G%bathyT(i+1,j+1)) + & (G%areaT(i+1,j) * G%bathyT(i+1,j) + G%areaT(i,j+1) * G%bathyT(i,j+1)) ) @@ -1396,8 +1396,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, gtot_W(i,j) * (Datu(I-1,j)*G%IdxCu(I-1,j))) + & (gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J)) + & gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1)))) + & - ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))) + US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))) H_eff_dx2 = max(H_min_dyn * (G%IdxT(i,j)**2 + G%IdyT(i,j)**2), & G%IareaT(i,j) * & ((Datu(I,j)*G%IdxCu(I,j) + Datu(I-1,j)*G%IdxCu(I-1,j)) + & @@ -2364,8 +2364,8 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) Idt_max2 = 0.5 * (1.0 + 2.0*CS%bebt) * (G%IareaT(i,j) * & ((gtot_E(i,j)*Datu(I,j)*G%IdxCu(I,j) + gtot_W(i,j)*Datu(I-1,j)*G%IdxCu(I-1,j)) + & (gtot_N(i,j)*Datv(i,J)*G%IdyCv(i,J) + gtot_S(i,j)*Datv(i,J-1)*G%IdyCv(i,J-1))) + & - ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))) + US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))) if (Idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / Idt_max2 enddo ; enddo dtbt_max = sqrt(min_max_dt2 / dgeo_de) @@ -3779,32 +3779,32 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, if (.not.CS%split) return call get_param(param_file, mdl, "BOUND_BT_CORRECTION", CS%bound_BT_corr, & - "If true, the corrective pseudo mass-fluxes into the \n"//& - "barotropic solver are limited to values that require \n"//& + "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.",default=.false.) call get_param(param_file, mdl, "BT_CONT_CORR_BOUNDS", CS%BT_cont_bounds, & - "If true, and BOUND_BT_CORRECTION is true, use the \n"//& - "BT_cont_type variables to set limits determined by \n"//& - "MAXCFL_BT_CONT on the CFL number of the velocites \n"//& + "If true, and BOUND_BT_CORRECTION is true, use the "//& + "BT_cont_type variables to set limits determined by "//& + "MAXCFL_BT_CONT on the CFL number of the velocities "//& "that are likely to be driven by the corrective mass fluxes.", & default=.true.) !, do_not_log=.not.CS%bound_BT_corr) call get_param(param_file, mdl, "ADJUST_BT_CONT", CS%adjust_BT_cont, & - "If true, adjust the curve fit to the BT_cont type \n"//& - "that is used by the barotropic solver to match the \n"//& + "If true, adjust the curve fit to the BT_cont type "//& + "that is used by the barotropic solver to match the "//& "transport about which the flow is being linearized.", default=.false.) call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & - "If true, adjust the initial conditions for the \n"//& - "barotropic solver to the values from the layered \n"//& - "solution over a whole timestep instead of instantly. \n"//& - "This is a decent approximation to the inclusion of \n"//& + "If true, adjust the initial conditions for the "//& + "barotropic solver to the values from the layered "//& + "solution over a whole timestep instead of instantly. "//& + "This is a decent approximation to the inclusion of "//& "sum(u dh_dt) while also correcting for truncation errors.", & default=.false.) call get_param(param_file, mdl, "BT_USE_VISC_REM_U_UH0", CS%visc_rem_u_uh0, & - "If true, use the viscous remnants when estimating the \n"//& - "barotropic velocities that were used to calculate uh0 \n"//& + "If true, use the viscous remnants when estimating the "//& + "barotropic velocities that were used to calculate uh0 "//& "and vh0. False is probably the better choice.", default=.false.) call get_param(param_file, mdl, "BT_USE_WIDE_HALOS", CS%use_wide_halos, & - "If true, use wide halos and march in during the \n"//& + "If true, use wide halos and march in during the "//& "barotropic time stepping for efficiency.", default=.true., & layoutParam=.true.) call get_param(param_file, mdl, "BTHALO", bt_halo_sz, & @@ -3812,7 +3812,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, layoutParam=.true.) #ifdef STATIC_MEMORY_ if ((bt_halo_sz > 0) .and. (bt_halo_sz /= BTHALO_)) call MOM_error(FATAL, & - "barotropic_init: Run-time values of BTHALO must agree with the \n"//& + "barotropic_init: Run-time values of BTHALO must agree with the "//& "macro BTHALO_ with STATIC_MEMORY_.") wd_halos(1) = WHALOI_+NIHALO_ ; wd_halos(2) = WHALOJ_+NJHALO_ #else @@ -3826,65 +3826,65 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, layoutParam=.true.) call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & - "If true, use a structure with elements that describe \n"//& - "effective face areas from the summed continuity solver \n"//& - "as a function the barotropic flow in coupling between \n"//& - "the barotropic and baroclinic flow. This is only used \n"//& + "If true, use a structure with elements that describe "//& + "effective face areas from the summed continuity solver "//& + "as a function the barotropic flow in coupling between "//& + "the barotropic and baroclinic flow. This is only used "//& "if SPLIT is true. \n", default=.true.) call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", & CS%Nonlinear_continuity, & - "If true, use nonlinear transports in the barotropic \n"//& - "continuity equation. This does not apply if \n"//& + "If true, use nonlinear transports in the barotropic "//& + "continuity equation. This does not apply if "//& "USE_BT_CONT_TYPE is true.", default=.false.) CS%Nonlin_cont_update_period = 1 if (CS%Nonlinear_continuity) & call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", & CS%Nonlin_cont_update_period, & - "If NONLINEAR_BT_CONTINUITY is true, this is the number \n"//& - "of barotropic time steps between updates to the face \n"//& + "If NONLINEAR_BT_CONTINUITY is true, this is the number "//& + "of barotropic time steps between updates to the face "//& "areas, or 0 to update only before the barotropic stepping.",& units="nondim", default=1) call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", CS%BT_project_velocity,& - "If true, step the barotropic velocity first and project \n"//& - "out the velocity tendancy by 1+BEBT when calculating the \n"//& - "transport. The default (false) is to use a predictor \n"//& - "continuity step to find the pressure field, and then \n"//& - "to do a corrector continuity step using a weighted \n"//& - "average of the old and new velocities, with weights \n"//& + "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.", default=.false.) call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & - "If true, add a dynamic pressure due to a viscous ice \n"//& + "If true, add a dynamic pressure due to a viscous ice "//& "shelf, for instance.", default=.false.) if (CS%dynamic_psurf) then call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & - "The length scale at which the Rayleigh damping rate due \n"//& - "to the ice strength should be the same as if a Laplacian \n"//& + "The length scale at which the Rayleigh damping rate due "//& + "to the ice strength should be the same as if a Laplacian "//& "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", & units="m", default=1.0e4) call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", CS%Dmin_dyn_psurf, & - "The minimum depth to use in limiting the size of the \n"//& - "dynamic surface pressure for stability, if \n"//& + "The minimum depth to use in limiting the size of the "//& + "dynamic surface pressure for stability, if "//& "DYNAMIC_SURFACE_PRESSURE is true..", units="m", & default=1.0e-6) call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & - "The constant that scales the dynamic surface pressure, \n"//& - "if DYNAMIC_SURFACE_PRESSURE is true. Stable values \n"//& + "The constant that scales the dynamic surface pressure, "//& + "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//& "are < ~1.0.", units="nondim", default=0.9) endif call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & - "If true, the Coriolis terms are discretized with the \n"//& - "Sadourny (1975) energy conserving scheme, otherwise \n"//& - "the Arakawa & Hsu scheme is used. If the internal \n"//& - "deformation radius is not resolved, the Sadourny scheme \n"//& + "If true, the Coriolis terms are discretized with the "//& + "Sadourny (1975) energy conserving scheme, otherwise "//& + "the Arakawa & Hsu scheme is used. If the internal "//& + "deformation radius is not resolved, the Sadourny scheme "//& "should probably be used.", default=.true.) call get_param(param_file, mdl, "BT_THICK_SCHEME", hvel_str, & - "A string describing the scheme that is used to set the \n"//& - "open face areas used for barotropic transport and the \n"//& + "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:\n"//& "\t ARITHMETIC - arithmetic mean layer thicknesses \n"//& "\t HARMONIC - harmonic mean layer thicknesses \n"//& @@ -3910,63 +3910,63 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "can only be used if USE_BT_CONT_TYPE is defined.") call get_param(param_file, mdl, "BT_STRONG_DRAG", CS%strong_drag, & - "If true, use a stronger estimate of the retarding \n"//& - "effects of strong bottom drag, by making it implicit \n"//& - "with the barotropic time-step instead of implicit with \n"//& - "the baroclinic time-step and dividing by the number of \n"//& + "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.", default=.false.) call get_param(param_file, mdl, "BT_LINEAR_WAVE_DRAG", CS%linear_wave_drag, & - "If true, apply a linear drag to the barotropic velocities, \n"//& - "using rates set by lin_drag_u & _vdivided by the depth of \n"//& + "If true, apply a linear drag to the barotropic velocities, "//& + "using rates set by lin_drag_u & _v divided by the depth of "//& "the ocean. This was introduced to facilitate tide modeling.", & default=.false.) call get_param(param_file, mdl, "BT_WAVE_DRAG_FILE", wave_drag_file, & - "The name of the file with the barotropic linear wave drag \n"//& + "The name of the file with the barotropic linear wave drag "//& "piston velocities.", default="", do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "BT_WAVE_DRAG_VAR", wave_drag_var, & - "The name of the variable in BT_WAVE_DRAG_FILE with the \n"//& + "The name of the variable in BT_WAVE_DRAG_FILE with the "//& "barotropic linear wave drag piston velocities at h points.", & default="rH", do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "BT_WAVE_DRAG_SCALE", wave_drag_scale, & - "A scaling factor for the barotropic linear wave drag \n"//& + "A scaling factor for the barotropic linear wave drag "//& "piston velocities.", default=1.0, units="nondim", & do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "CLIP_BT_VELOCITY", CS%clip_velocity, & - "If true, limit any velocity components that exceed \n"//& - "CFL_TRUNCATE. This should only be used as a desperate \n"//& + "If true, limit any velocity components that exceed "//& + "CFL_TRUNCATE. This should only be used as a desperate "//& "debugging measure.", default=.false.) call get_param(param_file, mdl, "CFL_TRUNCATE", CS%CFL_trunc, & - "The value of the CFL number that will cause velocity \n"//& + "The value of the CFL number that will cause velocity "//& "components to be truncated; instability can occur past 0.5.", & units="nondim", default=0.5, do_not_log=.not.CS%clip_velocity) call get_param(param_file, mdl, "MAXVEL", CS%maxvel, & - "The maximum velocity allowed before the velocity \n"//& + "The maximum velocity allowed before the velocity "//& "components are truncated.", units="m s-1", default=3.0e8, & do_not_log=.not.CS%clip_velocity) call get_param(param_file, mdl, "MAXCFL_BT_CONT", CS%maxCFL_BT_cont, & - "The maximum permitted CFL number associated with the \n"//& - "barotropic accelerations from the summed velocities \n"//& + "The maximum permitted CFL number associated with the "//& + "barotropic accelerations from the summed velocities "//& "times the time-derivatives of thicknesses.", units="nondim", & default=0.25) call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & - "A negligibly small velocity magnitude below which velocity \n"//& - "components are set to 0. A reasonable value might be \n"//& - "1e-30 m/s, which is less than an Angstrom divided by \n"//& + "A negligibly small velocity magnitude below which velocity "//& + "components are set to 0. A reasonable value might be "//& + "1e-30 m/s, which is less than an Angstrom divided by "//& "the age of the universe.", units="m s-1", default=0.0) call get_param(param_file, mdl, "DT_BT_FILTER", CS%dt_bt_filter, & - "A time-scale over which the barotropic mode solutions \n"//& - "are filtered, in seconds if positive, or as a fraction \n"//& - "of DT if negative. When used this can never be taken to \n"//& + "A time-scale over which the barotropic mode solutions "//& + "are filtered, in seconds if positive, or as a fraction "//& + "of DT if negative. When used this can never be taken to "//& "be longer than 2*dt. Set this to 0 to apply no filtering.", & units="sec or nondim", default=-0.25) call get_param(param_file, mdl, "G_BT_EXTRA", CS%G_extra, & "A nondimensional factor by which gtot is enhanced.", & units="nondim", default=0.0) call get_param(param_file, mdl, "SSH_EXTRA", SSH_extra, & - "An estimate of how much higher SSH might get, for use \n"//& - "in calculating the safe external wave speed. The \n"//& + "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.", & units="m", default=min(10.0,0.05*G%max_depth*US%Z_to_m), scale=US%m_to_Z) @@ -3974,33 +3974,33 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_BT", CS%debug_bt, & - "If true, write out verbose debugging data within the \n"//& - "barotropic time-stepping loop. The data volume can be \n"//& + "If true, write out verbose debugging data within the "//& + "barotropic time-stepping loop. The data volume can be "//& "quite large if this is true.", default=CS%debug, & debuggingParam=.true.) CS%linearized_BT_PV = .true. call get_param(param_file, mdl, "BEBT", CS%bebt, & - "BEBT determines whether the barotropic time stepping \n"//& - "uses the forward-backward time-stepping scheme or a \n"//& - "backward Euler scheme. BEBT is valid in the range from \n"//& - "0 (for a forward-backward treatment of nonrotating \n"//& - "gravity waves) to 1 (for a backward Euler treatment). \n"//& + "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.", & units="nondim", default=0.1) call get_param(param_file, mdl, "DTBT", dtbt_input, & - "The barotropic time step, in s. DTBT is only used with \n"//& - "the split explicit time stepping. To set the time step \n"//& - "automatically based the maximum stable value use 0, or \n"//& - "a negative value gives the fraction of the stable value. \n"//& - "Setting DTBT to 0 is the same as setting it to -0.98. \n"//& - "The value of DTBT that will actually be used is an \n"//& + "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.", units="s or nondim",& default = -0.98) call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", & CS%use_old_coriolis_bracket_bug , & - "If True, use an order of operations that is not bitwise\n"//& - "rotationally symmetric in the meridional Coriolis term of\n"//& + "If True, use an order of operations that is not bitwise "//& + "rotationally symmetric in the meridional Coriolis term of "//& "the barotropic solver.", default=.false.) ! Initialize a version of the MOM domain that is specific to the barotropic solver. @@ -4105,7 +4105,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, enddo ; enddo do J=js-1,je ; do I=is-1,ie if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then - CS%q_D(I,J) = 0.25 * G%CoriolisBu(I,J) * & + CS%q_D(I,J) = 0.25 * US%s_to_T*G%CoriolisBu(I,J) * & ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & ((G%areaT(i,j) * G%bathyT(i,j) + G%areaT(i+1,j+1) * G%bathyT(i+1,j+1)) + & (G%areaT(i+1,j) * G%bathyT(i+1,j) + G%areaT(i,j+1) * G%bathyT(i,j+1)) ) diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index cf4dc09897..ce69c9816c 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -148,7 +148,7 @@ subroutine continuity_init(Time, G, GV, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "CONTINUITY_SCHEME", tmpstr, & - "CONTINUITY_SCHEME selects the discretization for the \n"//& + "CONTINUITY_SCHEME selects the discretization for the "//& "continuity solver. The only valid value currently is: \n"//& "\t PPM - use a positive-definite (or monotonic) \n"//& "\t piecewise parabolic reconstruction solver.", & diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 3f6b699b20..4cf410160b 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -2258,66 +2258,66 @@ subroutine continuity_PPM_init(Time, G, GV, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MONOTONIC_CONTINUITY", CS%monotonic, & - "If true, CONTINUITY_PPM uses the Colella and Woodward \n"//& - "monotonic limiter. The default (false) is to use a \n"//& + "If true, CONTINUITY_PPM uses the Colella and Woodward "//& + "monotonic limiter. The default (false) is to use a "//& "simple positive definite limiter.", default=.false.) call get_param(param_file, mdl, "SIMPLE_2ND_PPM_CONTINUITY", CS%simple_2nd, & - "If true, CONTINUITY_PPM uses a simple 2nd order \n"//& - "(arithmetic mean) interpolation of the edge values. \n"//& - "This may give better PV conservation propterties. While \n"//& - "it formally reduces the accuracy of the continuity \n"//& - "solver itself in the strongly advective limit, it does \n"//& - "not reduce the overall order of accuracy of the dynamic \n"//& + "If true, CONTINUITY_PPM uses a simple 2nd order "//& + "(arithmetic mean) interpolation of the edge values. "//& + "This may give better PV conservation properties. 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.", default=.false.) call get_param(param_file, mdl, "UPWIND_1ST_CONTINUITY", CS%upwind_1st, & - "If true, CONTINUITY_PPM becomes a 1st-order upwind \n"//& - "continuity solver. This scheme is highly diffusive \n"//& - "but may be useful for debugging or in single-column \n"//& + "If true, CONTINUITY_PPM becomes a 1st-order upwind "//& + "continuity solver. This scheme is highly diffusive "//& + "but may be useful for debugging or in single-column "//& "mode where its minimal stencil is useful.", default=.false.) call get_param(param_file, mdl, "ETA_TOLERANCE", CS%tol_eta, & - "The tolerance for the differences between the \n"//& - "barotropic and baroclinic estimates of the sea surface \n"//& - "height due to the fluxes through each face. The total \n"//& - "tolerance for SSH is 4 times this value. The default \n"//& - "is 0.5*NK*ANGSTROM, and this should not be set less x\n"//& + "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.", units="m", scale=GV%m_to_H, & default=0.5*G%ke*GV%Angstrom_m, unscaled=tol_eta_m) call get_param(param_file, mdl, "ETA_TOLERANCE_AUX", CS%tol_eta_aux, & - "The tolerance for free-surface height discrepancies \n"//& - "between the barotropic solution and the sum of the \n"//& - "layer thicknesses when calculating the auxiliary \n"//& - "corrected velocities. By default, this is the same as \n"//& + "The tolerance for free-surface height discrepancies "//& + "between the barotropic solution and the sum of the "//& + "layer thicknesses when calculating the auxiliary "//& + "corrected velocities. By default, this is the same as "//& "ETA_TOLERANCE, but can be made larger for efficiency.", & units="m", default=tol_eta_m, scale=GV%m_to_H) call get_param(param_file, mdl, "VELOCITY_TOLERANCE", CS%tol_vel, & - "The tolerance for barotropic velocity discrepancies \n"//& - "between the barotropic solution and the sum of the \n"//& + "The tolerance for barotropic velocity discrepancies "//& + "between the barotropic solution and the sum of the "//& "layer thicknesses.", units="m s-1", default=3.0e8) ! The speed of light is the default. call get_param(param_file, mdl, "CONT_PPM_AGGRESS_ADJUST", CS%aggress_adjust,& - "If true, allow the adjusted velocities to have a \n"//& + "If true, allow the adjusted velocities to have a "//& "relative CFL change up to 0.5.", default=.false.) CS%vol_CFL = CS%aggress_adjust call get_param(param_file, mdl, "CONT_PPM_VOLUME_BASED_CFL", CS%vol_CFL, & - "If true, use the ratio of the open face lengths to the \n"//& - "tracer cell areas when estimating CFL numbers. The \n"//& + "If true, use the ratio of the open face lengths to the "//& + "tracer cell areas when estimating CFL numbers. The "//& "default is set by CONT_PPM_AGGRESS_ADJUST.", & default=CS%aggress_adjust, do_not_read=CS%aggress_adjust) call get_param(param_file, mdl, "CONTINUITY_CFL_LIMIT", CS%CFL_limit_adjust, & "The maximum CFL of the adjusted velocities.", units="nondim", & default=0.5) call get_param(param_file, mdl, "CONT_PPM_BETTER_ITER", CS%better_iter, & - "If true, stop corrective iterations using a velocity \n"//& - "based criterion and only stop if the iteration is \n"//& + "If true, stop corrective iterations using a velocity "//& + "based criterion and only stop if the iteration is "//& "better than all predecessors.", default=.true.) call get_param(param_file, mdl, "CONT_PPM_USE_VISC_REM_MAX", & CS%use_visc_rem_max, & - "If true, use more appropriate limiting bounds for \n"//& + "If true, use more appropriate limiting bounds for "//& "corrections in strongly viscous columns.", default=.true.) call get_param(param_file, mdl, "CONT_PPM_MARGINAL_FACE_AREAS", CS%marginal_faces, & - "If true, use the marginal face areas from the continuity \n"//& - "solver for use as the weights in the barotropic solver. \n"//& + "If true, use the marginal face areas from the continuity "//& + "solver for use as the weights in the barotropic solver. "//& "Otherwise use the transport averaged areas.", default=.true.) CS%diag => diag diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 2a4eeaf21a..d862fae71d 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -433,7 +433,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av call cpu_clock_begin(id_clock_Cor) call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & - G, Gv, CS%CoriolisAdv_CSp) + G, Gv, US, CS%CoriolisAdv_CSp) call cpu_clock_end(id_clock_Cor) if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)") @@ -682,14 +682,14 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & - MEKE, Varmix, G, GV, CS%hor_visc_CSp, OBC=CS%OBC) + MEKE, Varmix, G, GV, US, CS%hor_visc_CSp, OBC=CS%OBC) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av call cpu_clock_begin(id_clock_Cor) call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & - G, GV, CS%CoriolisAdv_CSp) + G, GV, US, CS%CoriolisAdv_CSp) call cpu_clock_end(id_clock_Cor) if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)") @@ -1023,28 +1023,28 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "BE", CS%be, & - "If SPLIT is true, BE determines the relative weighting \n"//& - "of a 2nd-order Runga-Kutta baroclinic time stepping \n"//& - "scheme (0.5) and a backward Euler scheme (1) that is \n"//& - "used for the Coriolis and inertial terms. BE may be \n"//& - "from 0.5 to 1, but instability may occur near 0.5. \n"//& - "BE is also applicable if SPLIT is false and USE_RK2 \n"//& + "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.", units="nondim", default=0.6) call get_param(param_file, mdl, "BEGW", CS%begw, & - "If SPLIT is true, BEGW is a number from 0 to 1 that \n"//& - "controls the extent to which the treatment of gravity \n"//& - "waves is forward-backward (0) or simulated backward \n"//& - "Euler (1). 0 is almost always used.\n"//& - "If SPLIT is false and USE_RK2 is true, BEGW can be \n"//& + "If SPLIT is true, BEGW is a number from 0 to 1 that "//& + "controls the extent to which the treatment of gravity "//& + "waves is forward-backward (0) or simulated backward "//& + "Euler (1). 0 is almost always used. "//& + "If SPLIT is false and USE_RK2 is true, BEGW can be "//& "between 0 and 0.5 to damp gravity waves.", & units="nondim", default=0.0) call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, & - "If true, provide the bottom stress calculated by the \n"//& + "If true, provide the bottom stress calculated by the "//& "vertical viscosity to the barotropic solver.", default=.false.) call get_param(param_file, mdl, "BT_USE_LAYER_FLUXES", CS%BT_use_layer_fluxes, & - "If true, use the summed layered fluxes plus an \n"//& - "adjustment due to the change in the barotropic velocity \n"//& + "If true, use the summed layered fluxes plus an "//& + "adjustment due to the change in the barotropic velocity "//& "in the barotropic continuity equation.", default=.true.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & @@ -1096,7 +1096,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) - call hor_visc_init(Time, G, param_file, diag, CS%hor_visc_CSp) + call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & @@ -1136,7 +1136,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (.not. query_initialized(CS%diffu,"diffu",restart_CS) .or. & .not. query_initialized(CS%diffv,"diffv",restart_CS)) & call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, & - G, GV, CS%hor_visc_CSp, OBC=CS%OBC) + G, GV, US, CS%hor_visc_CSp, OBC=CS%OBC) if (.not. query_initialized(CS%u_av,"u2", restart_CS) .or. & .not. query_initialized(CS%u_av,"v2", restart_CS)) then CS%u_av(:,:,:) = u(:,:,:) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 887a6c4f54..0995725536 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -255,7 +255,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call enable_averaging(dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, & - G, GV, CS%hor_visc_CSp) + G, GV, US, CS%hor_visc_CSp) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) @@ -300,7 +300,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! CAu = -(f+zeta)/h_av vh + d/dx KE call cpu_clock_begin(id_clock_Cor) call CorAdCalc(u, v, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & - G, GV, CS%CoriolisAdv_CSp) + G, GV, US, CS%CoriolisAdv_CSp) call cpu_clock_end(id_clock_Cor) ! PFu = d/dx M(h_av,T,S) @@ -368,7 +368,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! CAu = -(f+zeta(up))/h_av vh + d/dx KE(up) call cpu_clock_begin(id_clock_Cor) call CorAdCalc(up, vp, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & - G, GV, CS%CoriolisAdv_CSp) + G, GV, US, CS%CoriolisAdv_CSp) call cpu_clock_end(id_clock_Cor) ! PFu = d/dx M(h_av,T,S) @@ -450,7 +450,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! CAu = -(f+zeta(upp))/h_av vh + d/dx KE(upp) call cpu_clock_begin(id_clock_Cor) call CorAdCalc(upp, vpp, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & - G, GV, CS%CoriolisAdv_CSp) + G, GV, US, CS%CoriolisAdv_CSp) call cpu_clock_end(id_clock_Cor) ! PFu = d/dx M(h_av,T,S) @@ -653,7 +653,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) - call hor_visc_init(Time, G, param_file, diag, CS%hor_visc_CSp) + call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index e3625dd6a3..be81a8b25e 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -266,7 +266,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call enable_averaging(dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & - G, GV, CS%hor_visc_CSp) + G, GV, US, CS%hor_visc_CSp) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) call pass_vector(CS%diffu, CS%diffv, G%Domain, clock=id_clock_pass) @@ -295,7 +295,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! CAu = -(f+zeta)/h_av vh + d/dx KE (function of u[n-1] and uh[n-1]) call cpu_clock_begin(id_clock_Cor) call CorAdCalc(u_in, v_in, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & - G, GV, CS%CoriolisAdv_CSp) + G, GV, US, CS%CoriolisAdv_CSp) call cpu_clock_end(id_clock_Cor) ! PFu = d/dx M(h_av,T,S) (function of h[n-1/2]) @@ -367,7 +367,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! CAu = -(f+zeta(up))/h_av vh + d/dx KE(up) (function of up[n-1/2], h[n-1/2]) call cpu_clock_begin(id_clock_Cor) call CorAdCalc(up, vp, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & - G, GV, CS%CoriolisAdv_CSp) + G, GV, US, CS%CoriolisAdv_CSp) call cpu_clock_end(id_clock_Cor) if (associated(CS%OBC)) then call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) @@ -575,19 +575,19 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag CS%diag => diag call get_param(param_file, mdl, "BE", CS%be, & - "If SPLIT is true, BE determines the relative weighting \n"//& - "of a 2nd-order Runga-Kutta baroclinic time stepping \n"//& - "scheme (0.5) and a backward Euler scheme (1) that is \n"//& - "used for the Coriolis and inertial terms. BE may be \n"//& - "from 0.5 to 1, but instability may occur near 0.5. \n"//& - "BE is also applicable if SPLIT is false and USE_RK2 \n"//& + "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.", units="nondim", default=0.6) call get_param(param_file, mdl, "BEGW", CS%begw, & - "If SPLIT is true, BEGW is a number from 0 to 1 that \n"//& - "controls the extent to which the treatment of gravity \n"//& - "waves is forward-backward (0) or simulated backward \n"//& - "Euler (1). 0 is almost always used.\n"//& - "If SPLIT is false and USE_RK2 is true, BEGW can be \n"//& + "If SPLIT is true, BEGW is a number from 0 to 1 that "//& + "controls the extent to which the treatment of gravity "//& + "waves is forward-backward (0) or simulated backward "//& + "Euler (1). 0 is almost always used. "//& + "If SPLIT is false and USE_RK2 is true, BEGW can be "//& "between 0 and 0.5 to damp gravity waves.", & units="nondim", default=0.0) call get_param(param_file, mdl, "DEBUG", CS%debug, & @@ -613,7 +613,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) - call hor_visc_init(Time, G, param_file, diag, CS%hor_visc_CSp) + call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 7893b6ed86..b66aecd261 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -5,7 +5,7 @@ module MOM_grid use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_domains, only : MOM_domain_type, get_domain_extent, compute_block_extent -use MOM_domains, only : get_global_shape +use MOM_domains, only : get_global_shape, get_domain_extent_dsamp2 use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -26,6 +26,7 @@ module MOM_grid type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain type(MOM_domain_type), pointer :: Domain_aux => NULL() !< A non-symmetric auxiliary domain type. type(hor_index_type) :: HI !< Horizontal index ranges + type(hor_index_type) :: HId2 !< Horizontal index ranges for level-2-downsampling integer :: isc !< The start i-index of cell centers within the computational domain integer :: iec !< The end i-index of cell centers within the computational domain @@ -148,11 +149,11 @@ module MOM_grid Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m]. Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - CoriolisBu !< The Coriolis parameter at corner points [s-1]. + CoriolisBu !< The Coriolis parameter at corner points [T-1 ~> s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [s-1 m-1]. - df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [s-1 m-1]. - real :: g_Earth !< The gravitational acceleration [m s-2]. + df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [T-1 m-1 ~> s-1 m-1]. + df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [T-1 m-1 ~> s-1 m-1]. + real :: g_Earth !< The gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. ! These variables are global sums that are useful for 1-d diagnostics real :: areaT_global !< Global sum of h-cell area [m2] @@ -348,6 +349,23 @@ subroutine MOM_grid_init(G, param_file, HI, global_indexing, bathymetry_at_vel) if ( G%block(nblocks)%jed+G%block(nblocks)%jdg_offset > G%HI%jed + G%HI%jdg_offset ) & call MOM_error(FATAL, "MOM_grid_init: G%jed_bk > G%jed") + call get_domain_extent_dsamp2(G%Domain, G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec,& + G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed,& + G%HId2%isg, G%HId2%ieg, G%HId2%jsg, G%HId2%jeg) + + ! Set array sizes for fields that are discretized at tracer cell boundaries. + G%HId2%IscB = G%HId2%isc ; G%HId2%JscB = G%HId2%jsc + G%HId2%IsdB = G%HId2%isd ; G%HId2%JsdB = G%HId2%jsd + G%HId2%IsgB = G%HId2%isg ; G%HId2%JsgB = G%HId2%jsg + if (G%symmetric) then + G%HId2%IscB = G%HId2%isc-1 ; G%HId2%JscB = G%HId2%jsc-1 + G%HId2%IsdB = G%HId2%isd-1 ; G%HId2%JsdB = G%HId2%jsd-1 + G%HId2%IsgB = G%HId2%isg-1 ; G%HId2%JsgB = G%HId2%jsg-1 + endif + G%HId2%IecB = G%HId2%iec ; G%HId2%JecB = G%HId2%jec + G%HId2%IedB = G%HId2%ied ; G%HId2%JedB = G%HId2%jed + G%HId2%IegB = G%HId2%ieg ; G%HId2%JegB = G%HId2%jeg + end subroutine MOM_grid_init !> rescale_grid_bathymetry permits a change in the internal units for the bathymetry on the grid, diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c59eafc4c2..5624167170 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -305,8 +305,9 @@ subroutine open_boundary_config(G, US, param_file, OBC) real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries allocate(OBC) - call log_version(param_file, mdl, version, "Controls where open boundaries are located, what "//& - "kind of boundary condition to impose, and what data to apply, if any.") + call log_version(param_file, mdl, version, & + "Controls where open boundaries are located, what kind of boundary condition "//& + "to impose, and what data to apply, if any.") call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & "The number of open boundary segments.", & default=0) @@ -314,7 +315,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "OBC_USER_CONFIG", config1, & - "A string that sets how the open boundary conditions are \n"//& + "A string that sets how the open boundary conditions are "//& " configured: \n", default="none", do_not_log=.true.) call get_param(param_file, mdl, "NK", OBC%ke, & "The number of model layers", default=0, do_not_log=.true.) @@ -326,16 +327,16 @@ subroutine open_boundary_config(G, US, param_file, OBC) "If true, sets relative vorticity to zero on open boundaries.", & default=.false.) call get_param(param_file, mdl, "OBC_FREESLIP_VORTICITY", OBC%freeslip_vorticity, & - "If true, sets the normal gradient of tangential velocity to\n"// & - "zero in the relative vorticity on open boundaries. This cannot\n"// & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the relative vorticity on open boundaries. This cannot "//& "be true if another OBC_XXX_VORTICITY option is True.", default=.true.) call get_param(param_file, mdl, "OBC_COMPUTED_VORTICITY", OBC%computed_vorticity, & - "If true, uses the external values of tangential velocity\n"// & - "in the relative vorticity on open boundaries. This cannot\n"// & + "If true, uses the external values of tangential velocity "//& + "in the relative vorticity on open boundaries. This cannot "//& "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) call get_param(param_file, mdl, "OBC_SPECIFIED_VORTICITY", OBC%specified_vorticity, & - "If true, uses the external values of tangential velocity\n"// & - "in the relative vorticity on open boundaries. This cannot\n"// & + "If true, uses the external values of tangential velocity "//& + "in the relative vorticity on open boundaries. This cannot "//& "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) if ((OBC%zero_vorticity .and. OBC%freeslip_vorticity) .or. & (OBC%zero_vorticity .and. OBC%computed_vorticity) .or. & @@ -350,16 +351,16 @@ subroutine open_boundary_config(G, US, param_file, OBC) "If true, sets the strain used in the stress tensor to zero on open boundaries.", & default=.false.) call get_param(param_file, mdl, "OBC_FREESLIP_STRAIN", OBC%freeslip_strain, & - "If true, sets the normal gradient of tangential velocity to\n"// & - "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the strain use in the stress tensor on open boundaries. This cannot "//& "be true if another OBC_XXX_STRAIN option is True.", default=.true.) call get_param(param_file, mdl, "OBC_COMPUTED_STRAIN", OBC%computed_strain, & - "If true, sets the normal gradient of tangential velocity to\n"// & - "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the strain use in the stress tensor on open boundaries. This cannot "//& "be true if another OBC_XXX_STRAIN option is True.", default=.false.) call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN", OBC%specified_strain, & - "If true, sets the normal gradient of tangential velocity to\n"// & - "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the strain use in the stress tensor on open boundaries. This cannot "//& "be true if another OBC_XXX_STRAIN option is True.", default=.false.) if ((OBC%zero_strain .and. OBC%freeslip_strain) .or. & (OBC%zero_strain .and. OBC%computed_strain) .or. & @@ -367,11 +368,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) (OBC%freeslip_strain .and. OBC%computed_strain) .or. & (OBC%freeslip_strain .and. OBC%specified_strain) .or. & (OBC%computed_strain .and. OBC%specified_strain)) & - call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& - "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN\n"//& + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: \n"//& + "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//& "and OBC_IMPORTED_STRAIN can be True at once.") call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, & - "If true, zeros the Laplacian of flow on open boundaries in the biharmonic\n"//& + "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//& "viscosity term.", default=.false.) call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & "If true, set the areas outside open boundaries to be land.", & @@ -381,16 +382,16 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=.false.) if (debug_OBC .or. debug) & call log_param(param_file, mdl, "DEBUG_OBC", debug_OBC, & - "If true, do additional calls to help debug the performance \n"//& + "If true, do additional calls to help debug the performance "//& "of the open boundary condition code.", default=.false., & debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & - "A silly value of thicknesses used outside of open boundary \n"//& + "A silly value of thicknesses used outside of open boundary "//& "conditions for debugging.", units="m", default=0.0, & do_not_log=.not.debug_OBC, debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & - "A silly value of velocities used outside of open boundary \n"//& + "A silly value of velocities used outside of open boundary "//& "conditions for debugging.", units="m/s", default=0.0, & do_not_log=.not.debug_OBC, debuggingParam=.true.) reentrant_x = .false. @@ -448,15 +449,15 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & - "The maximum magnitude of the baroclinic radiation \n"//& - "velocity (or speed of characteristics). This is only \n"//& + "The maximum magnitude of the baroclinic radiation "//& + "velocity (or speed of characteristics). This is only "//& "used if one of the open boundary segments is using Orlanski.", & units="m s-1", default=10.0) call get_param(param_file, mdl, "OBC_RAD_VEL_WT", OBC%gamma_uv, & - "The relative weighting for the baroclinic radiation \n"//& - "velocities (or speed of characteristics) at the new \n"//& - "time level (1) or the running mean (0) for velocities. \n"//& - "Valid values range from 0 to 1. This is only used if \n"//& + "The relative weighting for the baroclinic radiation "//& + "velocities (or speed of characteristics) at the new "//& + "time level (1) or the running mean (0) for velocities. "//& + "Valid values range from 0 to 1. This is only used if "//& "one of the open boundary segments is using Orlanski.", & units="nondim", default=0.3) endif @@ -465,13 +466,13 @@ subroutine open_boundary_config(G, US, param_file, OBC) Lscale_out = 0. if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & - "An effective length scale for restoring the tracer concentration \n"//& - "at the boundaries to externally imposed values when the flow \n"//& + "An effective length scale for restoring the tracer concentration "//& + "at the boundaries to externally imposed values when the flow "//& "is exiting the domain.", units="m", default=0.0) call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & - "An effective length scale for restoring the tracer concentration \n"//& - "at the boundaries to values from the interior when the flow \n"//& + "An effective length scale for restoring the tracer concentration "//& + "at the boundaries to values from the interior when the flow "//& "is entering the domain.", units="m", default=0.0) endif @@ -546,21 +547,21 @@ subroutine initialize_segment_data(G, OBC, PF) inputdir = slasher(inputdir) call get_param(PF, mdl, "REMAPPING_SCHEME", remappingScheme, & - "This sets the reconstruction scheme used\n"//& - "for vertical remapping for all variables.\n"//& - "It can be one of the following schemes:\n"//& + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: \n"//& trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) call get_param(PF, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & - "If true, cell-by-cell reconstructions are checked for\n"//& - "consistency and if non-monotonicity or an inconsistency is\n"//& + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) call get_param(PF, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & - "If true, the results of remapping are checked for\n"//& - "conservation and new extrema and if an inconsistency is\n"//& + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) call get_param(PF, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & - "If true, the values on the intermediate grid used for remapping\n"//& - "are forced to be bounded, which might not be the case due to\n"//& + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& "round off.", default=.false.,do_not_log=.true.) call get_param(PF, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & "If true, read external OBC data on the supergrid.", & @@ -862,8 +863,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment,\n"//& - "for inflow, then outflow. Setting both to zero should\n"//& + "Timescales in days for nudging along a segment, "//& + "for inflow, then outflow. Setting both to zero should "//& "behave like SIMPLE obcs for the baroclinic velocities.", & fail_if_missing=.true.,default=0.,units="days") OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. @@ -891,7 +892,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) & - call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc:\n"//& + call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc: \n"//& "Orlanski and Oblique OBC options cannot be used together on one segment.") end subroutine setup_u_point_obc @@ -986,8 +987,8 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment,\n"//& - "for inflow, then outflow. Setting both to zero should\n"//& + "Timescales in days for nudging along a segment, "//& + "for inflow, then outflow. Setting both to zero should "//& "behave like SIMPLE obcs for the baroclinic velocities.", & fail_if_missing=.true.,default=0.,units="days") OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. @@ -1015,7 +1016,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) & - call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc:\n"//& + call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: \n"//& "Orlanski and Oblique OBC options cannot be used together on one segment.") end subroutine setup_v_point_obc diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index c623848c15..3748684fd4 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -80,7 +80,7 @@ module MOM_variables !> Pointers to an assortment of thermodynamic fields that may be available, including !! potential temperature, salinity, heat capacity, and the equation of state control structure. type, public :: thermo_var_ptrs -! If allocated, the following variables have nz layers. + ! If allocated, the following variables have nz layers. real, pointer :: T(:,:,:) => NULL() !< Potential temperature [degC]. real, pointer :: S(:,:,:) => NULL() !< Salnity [PSU] or [gSalt/kg], generically [ppt]. type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the @@ -95,14 +95,16 @@ module MOM_variables !! actually the conservative temperature [degC]. logical :: S_is_absS = .false. !< If true, the salinity variable tv%S is !! actually the absolute salinity in units of [gSalt/kg]. -! These arrays are accumulated fluxes for communication with other components. + real :: min_salinity = 0.01 !< The minimum value of salinity when BOUND_SALINITY=True [ppt]. + !! The default is 0.01 for backward compatibility but should be 0. + ! These arrays are accumulated fluxes for communication with other components. real, dimension(:,:), pointer :: frazil => NULL() !< The energy needed to heat the ocean column to the !! freezing point since calculate_surface_state was2 !! last called [J m-2]. real, dimension(:,:), pointer :: salt_deficit => NULL() !< The salt needed to maintain the ocean column - !! at a minumum salinity of 0.01 PSU since the last time + !! at a minimum salinity of MIN_SALINITY since the last time !! that calculate_surface_state was called, [gSalt m-2]. real, dimension(:,:), pointer :: TempxPmE => NULL() !< The net inflow of water into the ocean times the @@ -206,7 +208,8 @@ module MOM_variables ustar_BBL => NULL() !< The turbulence velocity in the bottom boundary layer at h points [Z s-1 ~> m s-1]. real, pointer, dimension(:,:) :: TKE_BBL => NULL() !< A term related to the bottom boundary layer source of turbulent kinetic - !! energy, currently in [m3 s-3], but will later be changed to [W m-2]. + !! energy, currently in [Z3 T-3 ~> m3 s-3], but may at some time be changed + !! to [kg Z3 m-3 T-3 ~> W m-2]. real, pointer, dimension(:,:) :: & taux_shelf => NULL(), & !< The zonal stresses on the ocean under shelves [Pa]. tauy_shelf => NULL() !< The meridional stresses on the ocean under shelves [Pa]. diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index a824553a84..83fb6d9268 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -50,7 +50,7 @@ module MOM_verticalGrid g_prime, & !< The reduced gravity at each interface [m2 Z-1 s-2 ~> m s-2]. Rlay !< The target coordinate value (potential density) in each layer [kg m-3]. integer :: nkml = 0 !< The number of layers at the top that should be treated - !! as parts of a homogenous region. + !! as parts of a homogeneous region. integer :: nk_rho_varies = 0 !< The number of layers at the top where the !! density does not track any target density. real :: H_to_kg_m2 !< A constant that translates thicknesses from the units of thickness to kg m-2. @@ -92,18 +92,18 @@ subroutine verticalGridInit( param_file, GV, US ) "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "RHO_0", GV%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, "BOUSSINESQ", GV%Boussinesq, & "If true, make the Boussinesq approximation.", default=.true.) call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_m, & - "The minumum layer thickness, usually one-Angstrom.", & + "The minimum layer thickness, usually one-Angstrom.", & units="m", default=1.0e-10) call get_param(param_file, mdl, "H_RESCALE_POWER", H_power, & - "An integer power of 2 that is used to rescale the model's \n"//& + "An integer power of 2 that is used to rescale the model's "//& "intenal units of thickness. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) if (abs(H_power) > 300) call MOM_error(FATAL, "verticalGridInit: "//& @@ -112,13 +112,13 @@ subroutine verticalGridInit( param_file, GV, US ) if (H_power /= 0) H_rescale_factor = 2.0**H_power if (.not.GV%Boussinesq) then call get_param(param_file, mdl, "H_TO_KG_M2", GV%H_to_kg_m2,& - "A constant that translates thicknesses from the model's \n"//& + "A constant that translates thicknesses from the model's "//& "internal units of thickness to kg m-2.", units="kg m-2 H-1", & default=1.0) GV%H_to_kg_m2 = GV%H_to_kg_m2 * H_rescale_factor else call get_param(param_file, mdl, "H_TO_M", GV%H_to_m, & - "A constant that translates the model's internal \n"//& + "A constant that translates the model's internal "//& "units of thickness into m.", units="m H-1", default=1.0) GV%H_to_m = GV%H_to_m * H_rescale_factor endif diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index a642cd0205..9c2f0b6adf 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -758,17 +758,17 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & - "The absolute path to the file where the accelerations \n"//& + "The absolute path to the file where the accelerations "//& "leading to zonal velocity truncations are written. \n"//& - "Leave this empty for efficiency if this diagnostic is \n"//& + "Leave this empty for efficiency if this diagnostic is "//& "not needed.", default="", debuggingParam=.true.) call get_param(param_file, mdl, "V_TRUNC_FILE", CS%v_trunc_file, & - "The absolute path to the file where the accelerations \n"//& + "The absolute path to the file where the accelerations "//& "leading to meridional velocity truncations are written. \n"//& - "Leave this empty for efficiency if this diagnostic is \n"//& + "Leave this empty for efficiency if this diagnostic is "//& "not needed.", default="", debuggingParam=.true.) call get_param(param_file, mdl, "MAX_TRUNC_FILE_SIZE_PER_PE", CS%max_writes, & - "The maximum number of colums of truncations that any PE \n"//& + "The maximum number of colums of truncations that any PE "//& "will write out during a run.", default=50, debuggingParam=.true.) if (len_trim(dirs%output_directory) > 0) then diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 79a56cae2f..d4d267d50d 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -88,11 +88,11 @@ subroutine MOM_debugging_init(param_file) "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_CHKSUMS", debug_chksums, & - "If true, checksums are performed on arrays in the \n"//& + "If true, checksums are performed on arrays in the "//& "various vec_chksum routines.", default=debug, & debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_REDUNDANT", debug_redundant, & - "If true, debug redundant data points during calls to \n"//& + "If true, debug redundant data points during calls to "//& "the various vec_chksum routines.", default=debug, & debuggingParam=.true.) diff --git a/src/diagnostics/MOM_diag_to_Z.F90 b/src/diagnostics/MOM_diag_to_Z.F90 index 3c50f00061..05e3d1486c 100644 --- a/src/diagnostics/MOM_diag_to_Z.F90 +++ b/src/diagnostics/MOM_diag_to_Z.F90 @@ -997,8 +997,8 @@ subroutine MOM_diag_to_Z_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, "") ! Read in z-space info from a NetCDF file. call get_param(param_file, mdl, "Z_OUTPUT_GRID_FILE", zgrid_file, & - "The file that specifies the vertical grid for \n"//& - "depth-space diagnostics, or blank to disable \n"//& + "The file that specifies the vertical grid for "//& + "depth-space diagnostics, or blank to disable "//& "depth-space output.", default="") if (len_trim(zgrid_file) > 0) then @@ -1011,7 +1011,7 @@ subroutine MOM_diag_to_Z_init(Time, G, GV, US, param_file, diag, CS) call log_param(param_file, mdl, "!INPUTDIR/Z_OUTPUT_GRID_FILE", & trim(in_dir)//trim(zgrid_file)) call log_param(param_file, mdl, "!NK_ZSPACE (from file)", CS%nk_zspace, & - "The number of depth-space levels. This is determined \n"//& + "The number of depth-space levels. This is determined "//& "from the size of the variable zw in the output grid file.", & units="nondim") else diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index cd3c87b922..859962c369 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -627,10 +627,10 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !$OMP private(f2_h,mag_beta) do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. - f2_h = absurdly_small_freq2 + 0.25 * & + f2_h = absurdly_small_freq2 + 0.25 * US%s_to_T**2 * & ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) - mag_beta = sqrt(0.5 * ( & + mag_beta = sqrt(0.5 * US%s_to_T**2 * ( & (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & @@ -676,10 +676,10 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !$OMP private(f2_h,mag_beta) do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. - f2_h = absurdly_small_freq2 + 0.25 * & + f2_h = absurdly_small_freq2 + 0.25 * US%s_to_T**2 * & ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) - mag_beta = sqrt(0.5 * ( & + mag_beta = sqrt(0.5 * US%s_to_T**2 * ( & (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & @@ -1450,11 +1450,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, 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, "DIAG_EBT_MONO_N2_COLUMN_FRACTION", CS%mono_N2_column_fraction, & - "The lower fraction of water column over which N2 is limited as monotonic\n"// & + "The lower fraction of water column over which N2 is limited as monotonic "// & "for the purposes of calculating the equivalent barotropic wave speed.", & units='nondim', default=0.) call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_DEPTH", CS%mono_N2_depth, & - "The depth below which N2 is limited as monotonic for the\n"// & + "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & units='m', default=-1.) @@ -1916,7 +1916,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) if (id > 0) call post_data(id, G%mask2dCv, diag, .true.) id = register_static_field('ocean_model', 'Coriolis', diag%axesB1, & - 'Coriolis parameter at corner (Bu) points', 's-1', interp_method='none') + 'Coriolis parameter at corner (Bu) points', 's-1', interp_method='none', conversion=US%s_to_T) if (id > 0) call post_data(id, G%CoriolisBu, diag, .true.) id = register_static_field('ocean_model', 'dxt', diag%axesT1, & diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 4bd5b61255..e30749984d 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -31,8 +31,8 @@ subroutine register_obsolete_diagnostics(param_file, diag) call log_version(param_file, mdl, version) call get_param(param_file, mdl, "OBSOLETE_DIAGNOSTIC_IS_FATAL", causeFatal, & - "If an obsolete diagnostic variable appears in the diag_table\n"// & - "then cause a FATAL error rather than issue a WARNING.", default=.true.) + "If an obsolete diagnostic variable appears in the diag_table, "// & + "cause a FATAL error rather than issue a WARNING.", default=.true.) foundEntry = .false. ! Each obsolete entry, with replacement name is available. diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index cfc74b47fc..9399f73a58 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -3,6 +3,7 @@ module MOM_sum_output ! This file is part of MOM6. See LICENSE.md for the license. +use iso_fortran_env, only : int64 use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs use MOM_coms, only : reproducing_sum, EFP_to_real, real_to_EFP use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=) @@ -24,6 +25,7 @@ module MOM_sum_output use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type +use mpp_mod, only : mpp_chksum use netcdf @@ -39,6 +41,13 @@ module MOM_sum_output ! vary with the Boussinesq approximation, the Boussinesq variant is given first. integer, parameter :: NUM_FIELDS = 17 !< Number of diagnostic fields +character (*), parameter :: depth_chksum_attr = "bathyT_checksum" + !< Checksum attribute name of G%bathyT + !! over the compute domain +character (*), parameter :: area_chksum_attr = "mask2dT_areaT_checksum" + !< Checksum attribute of name of + !! G%mask2dT * G%areaT over the compute + !! domain !> A list of depths and corresponding globally integrated ocean area at each !! depth and the ocean volume below each depth. @@ -64,6 +73,12 @@ module MOM_sum_output character(len=200) :: depth_list_file !< The name of the depth list file. real :: D_list_min_inc !< The minimum increment [Z ~> m], between the depths of the !! entries in the depth-list file, 0 by default. + logical :: require_depth_list_chksum + !< Require matching checksums in Depth_list.nc when reading + !! the file. + logical :: update_depth_list_chksum + !< Automatically update the Depth_list.nc file if the + !! checksums are missing or do not match current values. logical :: use_temperature !< If true, temperature and salinity are state variables. real :: fresh_water_input !< The total mass of fresh water added by surface fluxes !! since the last time that write_energy was called [kg]. @@ -154,41 +169,41 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "CALCULATE_APE", CS%do_APE_calc, & - "If true, calculate the available potential energy of \n"//& - "the interfaces. Setting this to false reduces the \n"//& + "If true, calculate the available potential energy of "//& + "the interfaces. Setting this to false reduces the "//& "memory footprint of high-PE-count models dramatically.", & default=.true.) call get_param(param_file, mdl, "WRITE_STOCKS", CS%write_stocks, & - "If true, write the integrated tracer amounts to stdout \n"//& + "If true, write the integrated tracer amounts to stdout "//& "when the energy files are written.", default=.true.) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "DT", CS%dt, & "The (baroclinic) dynamics time step.", units="s", & fail_if_missing=.true.) call get_param(param_file, mdl, "MAXTRUNC", CS%maxtrunc, & - "The run will be stopped, and the day set to a very \n"//& - "large value if the velocity is truncated more than \n"//& - "MAXTRUNC times between energy saves. Set MAXTRUNC to 0 \n"//& + "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.", & units="truncations save_interval-1", default=0) call get_param(param_file, mdl, "MAX_ENERGY", CS%max_Energy, & - "The maximum permitted average energy per unit mass; the \n"//& - "model will be stopped if there is more energy than \n"//& + "The maximum permitted average energy per unit mass; the "//& + "model will be stopped if there is more energy than "//& "this. If zero or negative, this is set to 10*MAXVEL^2.", & units="m2 s-2", default=0.0) if (CS%max_Energy <= 0.0) then call get_param(param_file, mdl, "MAXVEL", maxvel, & - "The maximum velocity allowed before the velocity \n"//& + "The maximum velocity allowed before the velocity "//& "components are truncated.", units="m s-1", default=3.0e8) CS%max_Energy = 10.0 * maxvel**2 call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy) endif call get_param(param_file, mdl, "ENERGYFILE", energyfile, & - "The file to use to write the energies and globally \n"//& + "The file to use to write the energies and globally "//& "summed diagnostics.", default="ocean.stats") !query fms_io if there is a filename_appendix (for ensemble runs) @@ -215,10 +230,10 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & if (CS%do_APE_calc) then call get_param(param_file, mdl, "READ_DEPTH_LIST", CS%read_depth_list, & - "Read the depth list from a file if it exists or \n"//& + "Read the depth list from a file if it exists or "//& "create that file otherwise.", default=.false.) call get_param(param_file, mdl, "DEPTH_LIST_MIN_INC", CS%D_list_min_inc, & - "The minimum increment between the depths of the \n"//& + "The minimum increment between the depths of the "//& "entries in the depth-list file.", & units="m", default=1.0E-10, scale=US%m_to_Z) if (CS%read_depth_list) then @@ -226,6 +241,17 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & "The name of the depth list file.", default="Depth_list.nc") if (scan(CS%depth_list_file,'/') == 0) & CS%depth_list_file = trim(slasher(directory))//trim(CS%depth_list_file) + + call get_param(param_file, mdl, "REQUIRE_DEPTH_LIST_CHECKSUMS", & + CS%require_depth_list_chksum, & + "Require that matching checksums be in Depth_list.nc "//& + "when reading the file.", default=.true.) + if (.not. CS%require_depth_list_chksum) & + call get_param(param_file, mdl, "UPDATE_DEPTH_LIST_CHECKSUMS", & + CS%update_depth_list_chksum, & + "Automatically update the Depth_list.nc file if the "//& + "checksums are missing or do not match current values.", & + default=.false.) endif allocate(CS%lH(G%ke)) @@ -238,12 +264,12 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & "The time unit for ENERGYSAVEDAYS.", & units="s", default=86400.0) call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & - "The interval in units of TIMEUNIT between saves of the \n"//& + "The interval in units of TIMEUNIT between saves of the "//& "energies of the run and other globally summed diagnostics.",& default=set_time(0,days=1), timeunit=Time_unit) call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & - "The starting interval in units of TIMEUNIT for the first call \n"//& - "to save the energies of the run and other globally summed diagnostics. \n"//& + "The starting interval in units of TIMEUNIT for the first call "//& + "to save the energies of the run and other globally summed diagnostics. "//& "The interval increases by a factor of 2. after each call to write_energy.",& default=set_time(seconds=0), timeunit=Time_unit) @@ -1102,7 +1128,7 @@ subroutine create_depth_list(G, CS) list_pos = (j_global-1)*G%Domain%niglobal + i_global Dlist(list_pos) = G%bathyT(i,j) - Arealist(list_pos) = G%mask2dT(i,j)*G%areaT(i,j) + Arealist(list_pos) = G%mask2dT(i,j) * G%areaT(i,j) enddo ; enddo ! These sums reproduce across PEs because the arrays are only nonzero on one PE. @@ -1203,6 +1229,10 @@ subroutine write_depth_list(G, US, CS, filename, list_size) ! Local variables real, allocatable :: tmp(:) integer :: ncid, dimid(1), Did, Aid, Vid, status, k + character(len=16) :: depth_chksum, area_chksum + + ! All ranks are required to compute the global checksum + call get_depth_list_checksums(G, depth_chksum, area_chksum) if (.not.is_root_pe()) return @@ -1248,6 +1278,15 @@ subroutine write_depth_list(G, US, CS, filename, list_size) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" vol_below "//trim(NF90_STRERROR(status))) + ! Dependency checksums + status = NF90_PUT_ATT(ncid, NF90_GLOBAL, depth_chksum_attr, depth_chksum) + if (status /= NF90_NOERR) call MOM_error(WARNING, & + filename//" "//depth_chksum_attr//" "//trim(NF90_STRERROR(status))) + + status = NF90_PUT_ATT(ncid, NF90_GLOBAL, area_chksum_attr, area_chksum) + if (status /= NF90_NOERR) call MOM_error(WARNING, & + filename//" "//area_chksum_attr//" "//trim(NF90_STRERROR(status))) + status = NF90_ENDDEF(ncid) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//trim(NF90_STRERROR(status))) @@ -1287,6 +1326,9 @@ subroutine read_depth_list(G, US, CS, filename) real, allocatable :: tmp(:) integer :: ncid, status, varid, list_size, k integer :: ndim, len, var_dim_ids(NF90_MAX_VAR_DIMS) + character(len=16) :: depth_file_chksum, depth_grid_chksum + character(len=16) :: area_file_chksum, area_grid_chksum + integer :: depth_attr_status, area_attr_status mdl = "MOM_sum_output read_depth_list:" @@ -1296,6 +1338,60 @@ subroutine read_depth_list(G, US, CS, filename) " - "//trim(NF90_STRERROR(status))) endif + ! Check bathymetric consistency + depth_attr_status = NF90_GET_ATT(ncid, NF90_GLOBAL, depth_chksum_attr, & + depth_file_chksum) + area_attr_status = NF90_GET_ATT(ncid, NF90_GLOBAL, area_chksum_attr, & + area_file_chksum) + + if (any([depth_attr_status, area_attr_status] == NF90_ENOTATT)) then + var_msg = trim(CS%depth_list_file) // " checksums are missing;" + if (CS%require_depth_list_chksum) then + call MOM_error(FATAL, trim(var_msg) // " aborting.") + elseif (CS%update_depth_list_chksum) then + call MOM_error(WARNING, trim(var_msg) // " updating file.") + call create_depth_list(G, CS) + call write_depth_list(G, US, CS, CS%depth_list_file, CS%list_size+1) + return + else + call MOM_error(WARNING, & + trim(var_msg) // " some diagnostics may not be reproducible.") + endif + else + ! Validate netCDF call + if (depth_attr_status /= NF90_NOERR) then + var_msg = mdl // "Failed to read " // trim(filename) // ":" & + // depth_chksum_attr + call MOM_error(FATAL, & + trim(var_msg) // " - " // NF90_STRERROR(depth_attr_status)) + endif + + if (area_attr_status /= NF90_NOERR) then + var_msg = mdl // "Failed to read " // trim(filename) // ":" & + // area_chksum_attr + call MOM_error(FATAL, & + trim(var_msg) // " - " // NF90_STRERROR(area_attr_status)) + endif + + call get_depth_list_checksums(G, depth_grid_chksum, area_grid_chksum) + + if (depth_grid_chksum /= depth_file_chksum & + .or. area_grid_chksum /= area_file_chksum) then + var_msg = trim(CS%depth_list_file) // " checksums do not match;" + if (CS%require_depth_list_chksum) then + call MOM_error(FATAL, trim(var_msg) // " aborting.") + elseif (CS%update_depth_list_chksum) then + call MOM_error(WARNING, trim(var_msg) // " updating file.") + call create_depth_list(G, CS) + call write_depth_list(G, US, CS, CS%depth_list_file, CS%list_size+1) + return + else + call MOM_error(WARNING, & + trim(var_msg) // " some diagnostics may not be reproducible.") + endif + endif + endif + var_name = "depth" var_msg = trim(var_name)//" in "//trim(filename)//" - " status = NF90_INQ_VARID(ncid, var_name, varid) @@ -1363,6 +1459,42 @@ subroutine read_depth_list(G, US, CS, filename) end subroutine read_depth_list + +!> Return the checksums required to verify DEPTH_LIST_FILE contents. +!! +!! This function computes checksums for the bathymetry (G%bathyT) and masked +!! area (mask2dT * areaT) fields of the model grid G, which are used to compute +!! the depth list. A difference in checksum indicates that a different method +!! was used to compute the grid data, and that any results using the depth +!! list, such as APE, will not be reproducible. +!! +!! Checksums are saved as hexadecimal strings, in order to avoid potential +!! datatype issues with netCDF attributes. +subroutine get_depth_list_checksums(G, depth_chksum, area_chksum) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + character(len=16), intent(out) :: depth_chksum !< Depth checksum hexstring + character(len=16), intent(out) :: area_chksum !< Area checksum hexstring + + integer :: i, j + real, allocatable :: field(:,:) + + allocate(field(G%isc:G%iec, G%jsc:G%jec)) + + ! Depth checksum + do j=G%jsc,G%jec ; do i=G%isc,G%iec + field(i,j) = G%bathyT(i,j) + enddo ; enddo + write(depth_chksum, '(Z16)') mpp_chksum(field(:,:)) + + ! Area checksum + do j=G%jsc,G%jec ; do i=G%isc,G%iec + field(i,j) = G%mask2dT(i,j) * G%areaT(i,j) + enddo ; enddo + write(area_chksum, '(Z16)') mpp_chksum(field(:,:)) + + deallocate(field) +end subroutine get_depth_list_checksums + !> \namespace mom_sum_output !! !! By Robert Hallberg, April 1994 - June 2002 diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 28ad4c6bfc..c289c540f0 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -459,8 +459,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo u_strct(nzm) = (w_strct(nzm-1)- w_strct(nzm))/dz(nzm-1) ! Calculate wavenumber magnitude - f2 = G%CoriolisBu(I,J)**2 - !f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + f2 = US%s_to_T**2 * G%CoriolisBu(I,J)**2 + !f2 = 0.25*US%s_to_T**2 *((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & ! (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) Kmag2 = (freq**2 - f2) / (cn(i,j)**2 + cg_subRO**2) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 9428307bd8..b2f15da465 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -719,9 +719,9 @@ subroutine EOS_init(param_file, EOS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "EQN_OF_STATE", tmpstr, & - "EQN_OF_STATE determines which ocean equation of state \n"//& - "should be used. Currently, the valid choices are \n"//& - '"LINEAR", "UNESCO", "WRIGHT", "NEMO" and "TEOS10". \n'//& + "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.", default=EOS_DEFAULT) select case (uppercase(tmpstr)) case (EOS_LINEAR_STRING) @@ -744,26 +744,26 @@ subroutine EOS_init(param_file, EOS) if (EOS%form_of_EOS == EOS_LINEAR) then EOS%Compressible = .false. call get_param(param_file, mdl, "RHO_T0_S0", EOS%Rho_T0_S0, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", \n"//& + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& "this is the density at T=0, S=0.", units="kg m-3", & default=1000.0) call get_param(param_file, mdl, "DRHO_DT", EOS%dRho_dT, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", \n"//& - "this is the partial derivative of density with \n"//& + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& + "this is the partial derivative of density with "//& "temperature.", units="kg m-3 K-1", default=-0.2) call get_param(param_file, mdl, "DRHO_DS", EOS%dRho_dS, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", \n"//& - "this is the partial derivative of density with \n"//& + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& + "this is the partial derivative of density with "//& "salinity.", units="kg m-3 PSU-1", default=0.8) endif call get_param(param_file, mdl, "EOS_QUADRATURE", EOS%EOS_quadrature, & - "If true, always use the generic (quadrature) code \n"//& + "If true, always use the generic (quadrature) code "//& "code for the integrals of density.", default=.false.) call get_param(param_file, mdl, "TFREEZE_FORM", tmpstr, & - "TFREEZE_FORM determines which expression should be \n"//& - "used for the freezing point. Currently, the valid \n"//& + "TFREEZE_FORM determines which expression should be "//& + "used for the freezing point. Currently, the valid "//& 'choices are "LINEAR", "MILLERO_78", "TEOS10"', & default=TFREEZE_DEFAULT) select case (uppercase(tmpstr)) @@ -780,17 +780,17 @@ subroutine EOS_init(param_file, EOS) if (EOS%form_of_TFreeze == TFREEZE_LINEAR) then call get_param(param_file, mdl, "TFREEZE_S0_P0",EOS%TFr_S0_P0, & - "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", \n"//& - "this is the freezing potential temperature at \n"//& + "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& + "this is the freezing potential temperature at "//& "S=0, P=0.", units="deg C", default=0.0) call get_param(param_file, mdl, "DTFREEZE_DS",EOS%dTFr_dS, & - "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", \n"//& - "this is the derivative of the freezing potential \n"//& + "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& + "this is the derivative of the freezing potential "//& "temperature with salinity.", & units="deg C PSU-1", default=-0.054) call get_param(param_file, mdl, "DTFREEZE_DP",EOS%dTFr_dP, & - "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", \n"//& - "this is the derivative of the freezing potential \n"//& + "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& + "this is the derivative of the freezing potential "//& "temperature with pressure.", & units="deg C Pa-1", default=0.0) endif diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 7d6fd2be60..4c91518e51 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -8,7 +8,7 @@ module MOM_diag_mediator use MOM_coms, only : PE_here use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, assert use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, query_vardesc, mom_read_data @@ -43,6 +43,7 @@ module MOM_diag_mediator #undef __DO_SAFETY_CHECKS__ #define IMPLIES(A, B) ((.not. (A)) .or. (B)) +#define MAX_DSAMP_LEV 2 public set_axes_info, post_data, register_diag_field, time_type public set_masks_for_axes @@ -68,6 +69,27 @@ module MOM_diag_mediator module procedure post_data_3d, post_data_2d, post_data_1d_k, post_data_0d end interface post_data +!> Down sample a field +interface downsample_field + module procedure downsample_field_2d, downsample_field_3d +end interface downsample_field + +!> Down sample the mask of a field +interface downsample_mask + module procedure downsample_mask_2d, downsample_mask_3d +end interface downsample_mask + +!> Down sample a diagnostic field +interface downsample_diag_field + module procedure downsample_diag_field_2d, downsample_diag_field_3d +end interface downsample_diag_field + +!> Contained for down sampled masks +type, private :: diag_dsamp + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes +end type diag_dsamp + !> A group of 1D axes that comprise a 1D/2D/3D mesh type, public :: axes_grp character(len=15) :: id !< The id string for this particular combination of handles. @@ -100,6 +122,7 @@ module MOM_diag_mediator logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled !! interface-located field that must be interpolated to !! these axes. Used for rank>2. + integer :: downsample_level = 1 !< If greater than 1, the factor by which this diagnostic/axes/masks be downsampled ! For horizontally averaged diagnositcs (applies to 2d and 3d fields only) type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontall area-averaged diagnostics ! ID's for cell_measures @@ -109,6 +132,7 @@ module MOM_diag_mediator ! For masking real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes + type(diag_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample container end type axes_grp !> Contains an array to store a diagnostic target grid @@ -123,6 +147,26 @@ module MOM_diag_mediator type(diag_grids_type), dimension(:), allocatable :: diag_grids !< Primarily empty, except h field end type diag_grid_storage +! Integers to encode the total cell methods +!integer :: PPP=111 ! x:point,y:point,z:point, this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPS=112 ! x:point,y:point,z:sum , this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPM=113 ! x:point,y:point,z:mean , this kind of diagnostic is not currently present in diag_table.MOM6 +integer :: PSP=121 !< x:point,y:sum,z:point +integer :: PSS=122 !< x:point,y:sum,z:point +integer :: PSM=123 !< x:point,y:sum,z:mean +integer :: PMP=131 !< x:point,y:mean,z:point +integer :: PMM=133 !< x:point,y:mean,z:mean +integer :: SPP=211 !< x:sum,y:point,z:point +integer :: SPS=212 !< x:sum,y:point,z:sum +integer :: SSP=221 !< x:sum;y:sum,z:point +integer :: MPP=311 !< x:mean,y:point,z:point +integer :: MPM=313 !< x:mean,y:point,z:mean +integer :: MMP=331 !< x:mean,y:mean,z:point +integer :: MMS=332 !< x:mean,y:mean,z:sum +integer :: SSS=222 !< x:sum,y:sum,z:sum +integer :: MMM=333 !< x:mean,y:mean,z:mean +integer :: MSK=-1 !< Use the downsample method of a mask + !> This type is used to represent a diagnostic at the diag_mediator level. !! !! There can be both 'primary' and 'seconday' diagnostics. The primaries @@ -134,14 +178,60 @@ module MOM_diag_mediator logical :: in_use !< True if this entry is being used. integer :: fms_diag_id !< Underlying FMS diag_manager id. integer :: fms_xyave_diag_id = -1 !< For a horizontally area-averaged diagnostic. + integer :: downsample_diag_id = -1 !< For a horizontally area-downsampled diagnostic. character(64) :: debug_str = '' !< For FATAL errors and debugging. type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). !! False for intensive (concentrations). + integer :: xyz_method = 0 !< A 3 digit integer encoding the diagnostics cell method + !! It can be used to determine the downsample algorithm end type diag_type +!> Container for down sampling information +type diagcs_dsamp + integer :: isc !< The start i-index of cell centers within the computational domain + integer :: iec !< The end i-index of cell centers within the computational domain + integer :: jsc !< The start j-index of cell centers within the computational domain + integer :: jec !< The end j-index of cell centers within the computational domain + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + integer :: isg !< The start i-index of cell centers within the global domain + integer :: ieg !< The end i-index of cell centers within the global domain + integer :: jsg !< The start j-index of cell centers within the global domain + integer :: jeg !< The end j-index of cell centers within the global domain + integer :: isgB !< The start i-index of cell corners within the global domain + integer :: iegB !< The end i-index of cell corners within the global domain + integer :: jsgB !< The start j-index of cell corners within the global domain + integer :: jegB !< The end j-index of cell corners within the global domain + + !>@{ Axes for each location on a diagnostic grid + type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL + type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi + type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 + type(axes_grp), dimension(:), allocatable :: remap_axesTL, remap_axesBL, remap_axesCuL, remap_axesCvL + type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi + !!@} + + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + real, dimension(:,:,:), pointer :: mask3dTL => null() + real, dimension(:,:,:), pointer :: mask3dBL => null() + real, dimension(:,:,:), pointer :: mask3dCuL => null() + real, dimension(:,:,:), pointer :: mask3dCvL => null() + real, dimension(:,:,:), pointer :: mask3dTi => null() + real, dimension(:,:,:), pointer :: mask3dBi => null() + real, dimension(:,:,:), pointer :: mask3dCui => null() + real, dimension(:,:,:), pointer :: mask3dCvi => null() + !!@} +end type diagcs_dsamp + !> The following data type a list of diagnostic fields an their variants, !! as well as variables that control the handling of model output. type, public :: diag_ctrl @@ -190,6 +280,9 @@ module MOM_diag_mediator real, dimension(:,:,:), pointer :: mask3dBi => null() real, dimension(:,:,:), pointer :: mask3dCui => null() real, dimension(:,:,:), pointer :: mask3dCvi => null() + + type(diagcs_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample control container + !!@} ! Space for diagnostics is dynamically allocated as it is needed. @@ -252,12 +345,14 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) !! vertical axes ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh - integer :: i, k, nz + integer :: id_zl_native, id_zi_native + integer :: i, j, k, nz real :: zlev(GV%ke), zinter(GV%ke+1) logical :: set_vert set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical + ! Horizontal axes for the native grids if (G%symmetric) then id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & 'q point nominal longitude', Domain2=G%Domain%mpp_domain) @@ -287,7 +382,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) else id_zl = -1 ; id_zi = -1 endif - + id_zl_native = id_zl ; id_zi_native = id_zi ! Vertical axes for the interfaces and layers call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, & v_cell_method='point', is_interface=.true.) @@ -335,6 +430,8 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) ! Axis group for special null axis from diag manager call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull) + + !Non-native Non-downsampled if (diag_cs%num_diag_coords>0) then allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords)) allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords)) @@ -420,10 +517,184 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) endif enddo + !Define the downsampled axes + call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) + call diag_grid_storage_init(diag_CS%diag_grid_temp, G, diag_CS) end subroutine set_axes_info +subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + integer, intent(in) :: id_zl_native !< ID of native layers + integer, intent(in) :: id_zi_native !< ID of native interfaces + + ! Local variables + integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh + integer :: i, j, k, nz, dl + real, dimension(:), pointer :: gridLonT_dsamp =>NULL() + real, dimension(:), pointer :: gridLatT_dsamp =>NULL() + real, dimension(:), pointer :: gridLonB_dsamp =>NULL() + real, dimension(:), pointer :: gridLatB_dsamp =>NULL() + + id_zl = id_zl_native ; id_zi = id_zi_native + !Axes group for native downsampled diagnostics + do dl=2,MAX_DSAMP_LEV + if(dl .ne. 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!") + if (G%symmetric) then + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB)) + do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo + do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + else + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + endif + + allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo + id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + + deallocate(gridLonT_dsamp,gridLatT_dsamp) + + ! Axis groupings for the model layers + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%axesBL, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%axesCuL, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%axesCvL, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + + ! Axis groupings for the model interfaces + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%axesTi, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%axesBi, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%axesCui, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%axesCvi, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + + ! Axis groupings for 2-D arrays + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh /), diag_cs%dsamp(dl)%axesT1, dl, & + x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq /), diag_cs%dsamp(dl)%axesB1, dl, & + x_cell_method='point', y_cell_method='point', is_q_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh /), diag_cs%dsamp(dl)%axesCu1, dl, & + x_cell_method='point', y_cell_method='mean', is_u_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, & + x_cell_method='mean', y_cell_method='point', is_v_point=.true.) + + !Non-native axes + if (diag_cs%num_diag_coords>0) then + allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCuL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesTi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCui(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvi(diag_cs%num_diag_coords)) + endif + + do i=1, diag_cs%num_diag_coords + ! For each possible diagnostic coordinate + !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file) + + ! This vertical coordinate has been configured so can be used. + if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then + + ! This fetches the 1D-axis id for layers and interfaces and overwrite + ! id_zl and id_zi from above. It also returns the number of layers. + call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zL, id_zi) + + ! Axes for z layers + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesTL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not + !! provided for remap_axesBL + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesBL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true., is_native=.false.) + + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesCuL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesCvL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + ! Axes for z interfaces + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesTi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., & + xyave_axes=diag_cs%remap_axesZi(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesBi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true., is_native=.false.) + + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesCui(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesCvi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + endif + enddo + enddo + +end subroutine set_axes_info_dsamp + + !> set_masks_for_axes sets up the 2d and 3d masks for diagnostics using the current grid !! recorded after calling diag_update_remap_grids() subroutine set_masks_for_axes(G, diag_cs) @@ -431,7 +702,7 @@ subroutine set_masks_for_axes(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, nk, i, j, k + integer :: c, nk, i, j, k, ii, jj type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience do c=1, diag_cs%num_diag_coords @@ -520,8 +791,70 @@ subroutine set_masks_for_axes(G, diag_cs) endif enddo + !Allocate and initialize the downsampled masks for the axes + call set_masks_for_axes_dsamp(G, diag_cs) + end subroutine set_masks_for_axes +subroutine set_masks_for_axes_dsamp(G, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: c, nk, i, j, k, ii, jj + integer :: dl + type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience + + !Each downsampled axis needs both downsampled and non-downsampled mask + !The downsampled mask is needed for sending out the diagnostics output via diag_manager + !The non-downsampled mask is needed for downsampling the diagnostics field + do dl=2,MAX_DSAMP_LEV + if(dl .ne. 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!") + do c=1, diag_cs%num_diag_coords + ! Level/layer h-points in diagnostic coordinate + axes => diag_cs%remap_axesTL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Level/layer u-points in diagnostic coordinate + axes => diag_cs%remap_axesCuL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Level/layer v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Level/layer q-points in diagnostic coordinate + axes => diag_cs%remap_axesBL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface h-points in diagnostic coordinate (w-point) + axes => diag_cs%remap_axesTi(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface u-points in diagnostic coordinate + axes => diag_cs%remap_axesCui(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvi(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface q-points in diagnostic coordinate + axes => diag_cs%remap_axesBi(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask + enddo + enddo +end subroutine set_masks_for_axes_dsamp + !> Attaches the id of cell areas to axes groups for use with cell_measures subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q) type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure @@ -707,6 +1040,144 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num end subroutine define_axes_group +!> Defines a group of downsampled "axes" from list of handles +subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coordinate_number, & + x_cell_method, y_cell_method, v_cell_method, & + is_h_point, is_q_point, is_u_point, is_v_point, & + is_layer, is_interface, & + is_native, needs_remapping, needs_interpolating, & + xyave_axes) + type(diag_ctrl), target, intent(in) :: diag_cs !< Diagnostics control structure + integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles + type(axes_grp), intent(out) :: axes !< The group of 1D axes + integer, intent(in) :: dl !< Downsample level + integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid + integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate + character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct + !! the "cell_methods" attribute in CF convention + logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point + !! located fields + logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point + !! located fields + logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for + !! u-point located fields + logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for + !! v-point located fields + logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is + !! for a layer vertically-located field. + logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group + !! is for an interface vertically-located field. + logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is + !! for a native model grid. False for any other grid. + logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is + !! for a intensive layer-located field that must + !! be remapped to these axes. Used for rank>2. + logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group + !! is for a sampled interface-located field that must + !! be interpolated to these axes. Used for rank>2. + type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally + !! area-average diagnostics + ! Local variables + integer :: n + + n = size(handles) + if (n<1 .or. n>3) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!") + allocate( axes%handles(n) ) + axes%id = i2s(handles, n) ! Identifying string + axes%rank = n + axes%handles(:) = handles(:) + axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure + if (present(x_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set x_cell_method for rank<2.') + axes%x_cell_method = trim(x_cell_method) + else + axes%x_cell_method = '' + endif + if (present(y_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set y_cell_method for rank<2.') + axes%y_cell_method = trim(y_cell_method) + else + axes%y_cell_method = '' + endif + if (present(v_cell_method)) then + if (axes%rank/=1 .and. axes%rank/=3) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set v_cell_method for rank<>1 or 3.') + axes%v_cell_method = trim(v_cell_method) + else + axes%v_cell_method = '' + endif + axes%downsample_level = dl + if (present(nz)) axes%nz = nz + if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number + if (present(is_h_point)) axes%is_h_point = is_h_point + if (present(is_q_point)) axes%is_q_point = is_q_point + if (present(is_u_point)) axes%is_u_point = is_u_point + if (present(is_v_point)) axes%is_v_point = is_v_point + if (present(is_layer)) axes%is_layer = is_layer + if (present(is_interface)) axes%is_interface = is_interface + if (present(is_native)) axes%is_native = is_native + if (present(needs_remapping)) axes%needs_remapping = needs_remapping + if (present(needs_interpolating)) axes%needs_interpolating = needs_interpolating + if (present(xyave_axes)) axes%xyave_axes => xyave_axes + + ! Setup masks for this axes group + + axes%mask2d => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT + if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu + if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv + if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu + endif + ! A static 3d mask for non-native coordinates can only be setup when a grid is available + axes%mask3d => null() + if (axes%rank==3 .and. axes%is_native) then + ! Native variables can/should use the native masks copied into diag_cs + if (axes%is_layer) then + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL + elseif (axes%is_interface) then + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi + endif + endif + + axes%dsamp(dl)%mask2d => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dT + if (axes%is_u_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCu + if (axes%is_v_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCv + if (axes%is_q_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dBu + endif + ! A static 3d mask for non-native coordinates can only be setup when a grid is available + axes%dsamp(dl)%mask3d => null() + if (axes%rank==3 .and. axes%is_native) then + ! Native variables can/should use the native masks copied into diag_cs + if (axes%is_layer) then + if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTL + if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCuL + if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvL + if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBL + elseif (axes%is_interface) then + if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTi + if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCui + if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvi + if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBi + endif + endif + +end subroutine define_axes_group_dsamp + !> Set up the array extents for doing diagnostics subroutine set_diag_mediator_grid(G, diag_cs) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure @@ -836,15 +1307,21 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. ! Local variables - real, dimension(:,:), pointer :: locfield => NULL() + real, dimension(:,:), pointer :: locfield + real, dimension(:,:), pointer :: locmask character(len=300) :: mesg logical :: used, is_stat integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, i, j, chksum + integer :: isv, iev, jsv, jev, i, j, chksum, isv_o,jsv_o + real, dimension(:,:), allocatable, target :: locfield_dsamp + real, dimension(:,:), allocatable, target :: locmask_dsamp + integer :: dl + locfield => NULL() + locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static ! Determine the propery array indices, noting that because of the (:,:) @@ -897,6 +1374,29 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) else locfield => field endif + + if (present(mask)) then + locmask => mask + elseif(.NOT. is_stat) then + if(associated(diag%axes%mask2d)) locmask => diag%axes%mask2d + endif + + dl=1 + if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet + !Downsample the diag field and mask (if present) + if (dl > 1) then + isv_o=isv ; jsv_o=jsv + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) + locfield => locfield_dsamp + if (present(mask)) then + call downsample_field_2d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) + locmask => locmask_dsamp + elseif(associated(diag%axes%dsamp(dl)%mask2d)) then + locmask => diag%axes%dsamp(dl)%mask2d + endif + endif + if (diag_cs%diag_as_chksum) then chksum = chksum_general(locfield) if (is_root_pe()) then @@ -905,10 +1405,10 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) else if (is_stat) then if (present(mask)) then - call assert(size(locfield) == size(mask), & + call assert(size(locfield) == size(locmask), & 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) !elseif (associated(diag%axes%mask2d)) then ! used = send_data(diag%fms_diag_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) @@ -917,16 +1417,12 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then - if (present(mask)) then - call assert(size(locfield) == size(mask), & + if (associated(locmask)) then + call assert(size(locfield) == size(locmask), & 'post_data_2d_low: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=mask) - elseif (associated(diag%axes%mask2d)) then - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%axes%mask2d) + weight=diag_cs%time_int, rmask=locmask) else used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & @@ -934,9 +1430,8 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) endif endif endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & deallocate( locfield ) - end subroutine post_data_2d_low !> Make a real 3-d array diagnostic available for averaging or output. @@ -1066,18 +1561,24 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) real, target, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. ! Local variables - real, dimension(:,:,:), pointer :: locfield => NULL() + real, dimension(:,:,:), pointer :: locfield + real, dimension(:,:,:), pointer :: locmask character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. logical :: staggered_in_x, staggered_in_y logical :: is_stat integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c + integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o integer :: chksum + real, dimension(:,:,:), allocatable, target :: locfield_dsamp + real, dimension(:,:,:), allocatable, target :: locmask_dsamp + integer :: dl + locfield => NULL() + locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static ! Determine the proper array indices, noting that because of the (:,:) @@ -1117,8 +1618,8 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) endif + ks = lbound(field,3) ; ke = ubound(field,3) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then - ks = lbound(field,3) ; ke = ubound(field,3) allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) ) ! locfield(:,:,:) = 0.0 ! Zeroing out this array would be a good idea, but it appears ! not to be necessary. @@ -1137,7 +1638,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) "have j-direction space to represent the symmetric computational domain.") endif - do k=ks,ke ; do j=jsv_c,jev ; do i=isv_c,iev + do k=ks,ke ; do j=jsv,jev ; do i=isv,iev if (field(i,j,k) == diag_cs%missing_value) then locfield(i,j,k) = diag_cs%missing_value else @@ -1148,6 +1649,28 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) locfield => field endif + if (present(mask)) then + locmask => mask + elseif(associated(diag%axes%mask3d)) then + locmask => diag%axes%mask3d + endif + + dl=1 + if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet + !Downsample the diag field and mask (if present) + if (dl > 1) then + isv_o=isv ; jsv_o=jsv + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) + locfield => locfield_dsamp + if (present(mask)) then + call downsample_field_3d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) + locmask => locmask_dsamp + elseif(associated(diag%axes%dsamp(dl)%mask3d)) then + locmask => diag%axes%dsamp(dl)%mask3d + endif + endif + if (diag%fms_diag_id>0) then if (diag_cs%diag_as_chksum) then chksum = chksum_general(locfield) @@ -1157,30 +1680,24 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) else if (is_stat) then if (present(mask)) then - call assert(size(locfield) == size(mask), & + call assert(size(locfield) == size(locmask), & 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) - !elseif (associated(diag%axes%mask3d)) then - ! used = send_data(diag_field_id, locfield, & - ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask3d) + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) + !elseif (associated(diag%axes%mask2d)) then + ! used = send_data(diag%fms_diag_id, locfield, & + ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) else used = send_data(diag%fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then - if (present(mask)) then - call assert(size(locfield) == size(mask), & + if (associated(locmask)) then + call assert(size(locfield) == size(locmask), & 'post_data_3d_low: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=mask) - elseif (associated(diag%axes%mask3d)) then - call assert(size(locfield) == size(diag%axes%mask3d), & - 'post_data_3d_low: mask3d size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%axes%mask3d) + weight=diag_cs%time_int, rmask=locmask) else used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & @@ -1189,10 +1706,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) endif endif endif - if (diag%fms_xyave_diag_id>0) then - call post_xy_average(diag_cs, diag, locfield) - endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & deallocate( locfield ) end subroutine post_data_3d_low @@ -1293,7 +1807,7 @@ end function get_diag_time_end !> Returns the "diag_mediator" handle for a group (native, CMOR, z-coord, ...) of diagnostics !! derived from one field. -integer function register_diag_field(module_name, field_name, axes, init_time, & +integer function register_diag_field(module_name, field_name, axes_in, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & @@ -1301,7 +1815,7 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + type(axes_grp), target, intent(in) :: axes_in !< Container w/ up to 3 integer handles that !! indicates axes for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. @@ -1339,16 +1853,36 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & real :: MOM_missing_value type(diag_ctrl), pointer :: diag_cs => NULL() type(axes_grp), pointer :: remap_axes => null() - integer :: dm_id, i + type(axes_grp), pointer :: axes => null() + integer :: dm_id, i, dl character(len=256) :: new_module_name logical :: active + axes => axes_in MOM_missing_value = axes%diag_cs%missing_value if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs dm_id = -1 + if (axes_in%id == diag_cs%axesTL%id) then + axes => diag_cs%axesTL + elseif (axes_in%id == diag_cs%axesBL%id) then + axes => diag_cs%axesBL + elseif (axes_in%id == diag_cs%axesCuL%id ) then + axes => diag_cs%axesCuL + elseif (axes_in%id == diag_cs%axesCvL%id) then + axes => diag_cs%axesCvL + elseif (axes_in%id == diag_cs%axesTi%id) then + axes => diag_cs%axesTi + elseif (axes_in%id == diag_cs%axesBi%id) then + axes => diag_cs%axesBi + elseif (axes_in%id == diag_cs%axesCui%id ) then + axes => diag_cs%axesCui + elseif (axes_in%id == diag_cs%axesCvi%id) then + axes => diag_cs%axesCvi + endif + ! Register the native diagnostic active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & @@ -1366,23 +1900,23 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix) ! Register diagnostics remapped to z vertical coordinate - if (axes%rank == 3) then + if (axes_in%rank == 3) then remap_axes => null() - if ((axes%id == diag_cs%axesTL%id)) then + if ((axes_in%id == diag_cs%axesTL%id)) then remap_axes => diag_cs%remap_axesTL(i) - elseif (axes%id == diag_cs%axesBL%id) then + elseif (axes_in%id == diag_cs%axesBL%id) then remap_axes => diag_cs%remap_axesBL(i) - elseif (axes%id == diag_cs%axesCuL%id ) then + elseif (axes_in%id == diag_cs%axesCuL%id ) then remap_axes => diag_cs%remap_axesCuL(i) - elseif (axes%id == diag_cs%axesCvL%id) then + elseif (axes_in%id == diag_cs%axesCvL%id) then remap_axes => diag_cs%remap_axesCvL(i) - elseif (axes%id == diag_cs%axesTi%id) then + elseif (axes_in%id == diag_cs%axesTi%id) then remap_axes => diag_cs%remap_axesTi(i) - elseif (axes%id == diag_cs%axesBi%id) then + elseif (axes_in%id == diag_cs%axesBi%id) then remap_axes => diag_cs%remap_axesBi(i) - elseif (axes%id == diag_cs%axesCui%id ) then + elseif (axes_in%id == diag_cs%axesCui%id ) then remap_axes => diag_cs%remap_axesCui(i) - elseif (axes%id == diag_cs%axesCvi%id) then + elseif (axes_in%id == diag_cs%axesCvi%id) then remap_axes => diag_cs%remap_axesCvi(i) endif ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will @@ -1408,11 +1942,110 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & endif ! axes%rank == 3 enddo ! i + !Register downsampled diagnostics + do dl=2,MAX_DSAMP_LEV + new_module_name = trim(module_name)//'_d2' + + if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then + axes => null() + if (axes_in%id == diag_cs%axesTL%id) then + axes => diag_cs%dsamp(dl)%axesTL + elseif (axes_in%id == diag_cs%axesBL%id) then + axes => diag_cs%dsamp(dl)%axesBL + elseif (axes_in%id == diag_cs%axesCuL%id ) then + axes => diag_cs%dsamp(dl)%axesCuL + elseif (axes_in%id == diag_cs%axesCvL%id) then + axes => diag_cs%dsamp(dl)%axesCvL + elseif (axes_in%id == diag_cs%axesTi%id) then + axes => diag_cs%dsamp(dl)%axesTi + elseif (axes_in%id == diag_cs%axesBi%id) then + axes => diag_cs%dsamp(dl)%axesBi + elseif (axes_in%id == diag_cs%axesCui%id ) then + axes => diag_cs%dsamp(dl)%axesCui + elseif (axes_in%id == diag_cs%axesCvi%id) then + axes => diag_cs%dsamp(dl)%axesCvi + elseif (axes_in%id == diag_cs%axesT1%id) then + axes => diag_cs%dsamp(dl)%axesT1 + elseif (axes_in%id == diag_cs%axesB1%id) then + axes => diag_cs%dsamp(dl)%axesB1 + elseif (axes_in%id == diag_cs%axesCu1%id ) then + axes => diag_cs%dsamp(dl)%axesCu1 + elseif (axes_in%id == diag_cs%axesCv1%id) then + axes => diag_cs%dsamp(dl)%axesCv1 + else + !Niki: Should we worry about these, e.g., diag_to_Z_CS? + call MOM_error(WARNING,"register_diag_field: Could not find a proper axes for " & + //trim( new_module_name)//"-"//trim(field_name)) + endif + endif + ! Register the native diagnostic + if (associated(axes)) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + endif + + ! For each diagnostic coordinate register the diagnostic again under a different module name + do i=1,diag_cs%num_diag_coords + new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)//'_d2' + + ! Register diagnostics remapped to z vertical coordinate + if (axes_in%rank == 3) then + remap_axes => null() + if ((axes_in%id == diag_cs%axesTL%id)) then + remap_axes => diag_cs%dsamp(dl)%remap_axesTL(i) + elseif (axes_in%id == diag_cs%axesBL%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesBL(i) + elseif (axes_in%id == diag_cs%axesCuL%id ) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCuL(i) + elseif (axes_in%id == diag_cs%axesCvL%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCvL(i) + elseif (axes_in%id == diag_cs%axesTi%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesTi(i) + elseif (axes_in%id == diag_cs%axesBi%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesBi(i) + elseif (axes_in%id == diag_cs%axesCui%id ) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCui(i) + elseif (axes_in%id == diag_cs%axesCvi%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCvi(i) + endif + + ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will + ! always exist but in the mean-time we have to do this check: + ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set') + if (associated(remap_axes)) then + if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + if (active) then + call diag_remap_set_active(diag_cs%diag_remap_cs(i)) + endif + endif ! remap_axes%needs_remapping + endif ! associated(remap_axes) + endif ! axes%rank == 3 + enddo ! i + enddo + register_diag_field = dm_id end function register_diag_field -!> Returns True if either the native of CMOr version of the diagnostic were registered. Updates 'dm_id' +!> Returns True if either the native or CMOr version of the diagnostic were registered. Updates 'dm_id' !! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field. logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & @@ -1506,7 +2139,8 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) this_diag%fms_xyave_diag_id = fms_xyave_id - + !Encode and save the cell methods for this diag + call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) if (present(v_extensive)) this_diag%v_extensive = v_extensive if (present(conversion)) this_diag%conversion_factor = conversion register_diag_field_expand_cmor = .true. @@ -1566,7 +2200,8 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) this_diag%fms_xyave_diag_id = fms_xyave_id - + !Encode and save the cell methods for this diag + call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) if (present(v_extensive)) this_diag%v_extensive = v_extensive if (present(conversion)) this_diag%conversion_factor = conversion register_diag_field_expand_cmor = .true. @@ -1702,6 +2337,69 @@ subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name end subroutine add_diag_to_list +!> Adds the encoded "cell_methods" for a diagnostics as a diag% property +!! This allows access to the cell_method for a given diagnostics at the time of sending +subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) + type(diag_type), pointer :: diag !< This diagnostic + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields + !! (vertically integrated). Default/absent for intensive. + integer :: xyz_method + character(len=9) :: mstr + + !This is a simple way to encode the cell method information made from 3 strings + !(x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz + !x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean' + !We can encode these with setting 1 for 'point', 2 for 'sum, 3 for 'mean' in + !the 100s position for x, 10s position for y, 1s position for z + !E.g., x:sum,y:point,z:mean is 213 + + xyz_method = 111 + + mstr = diag%axes%v_cell_method + if (present(v_extensive)) then + if (present(v_cell_method)) call MOM_error(FATAL, "attach_cell_methods: " // & + 'Vertical cell method was specified along with the vertically extensive flag.') + if(v_extensive) then + mstr='sum' + else + mstr='mean' + endif + elseif (present(v_cell_method)) then + mstr = v_cell_method + endif + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 1 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 2 + endif + + mstr = diag%axes%y_cell_method + if (present(y_cell_method)) mstr = y_cell_method + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 10 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 20 + endif + + mstr = diag%axes%x_cell_method + if (present(x_cell_method)) mstr = x_cell_method + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 100 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 200 + endif + + diag%xyz_method = xyz_method +end subroutine add_xyz_method + !> Attaches "cell_methods" attribute to a variable based on defaults for axes_grp or optional arguments. subroutine attach_cell_methods(id, axes, ostring, cell_methods, & x_cell_method, y_cell_method, v_cell_method, v_extensive) @@ -2216,21 +2914,21 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, 'NUM_DIAG_COORDS', diag_cs%num_diag_coords, & - 'The number of diagnostic vertical coordinates to use.\n'//& + 'The number of diagnostic vertical coordinates to use. '//& 'For each coordinate, an entry in DIAG_COORDS must be provided.', & default=1) if (diag_cs%num_diag_coords>0) then allocate(diag_coords(diag_cs%num_diag_coords)) if (diag_cs%num_diag_coords==1) then ! The default is to provide just one instance of Z* call get_param(param_file, mdl, 'DIAG_COORDS', diag_coords, & - 'A list of string tuples associating diag_table modules to\n'//& - 'a coordinate definition used for diagnostics. Each string\n'//& + 'A list of string tuples associating diag_table modules to '//& + 'a coordinate definition used for diagnostics. Each string '//& 'is of the form "MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME".', & default='z Z ZSTAR') else ! If using more than 1 diagnostic coordinate, all must be explicitly defined call get_param(param_file, mdl, 'DIAG_COORDS', diag_coords, & - 'A list of string tuples associating diag_table modules to\n'//& - 'a coordinate definition used for diagnostics. Each string\n'//& + 'A list of string tuples associating diag_table modules to '//& + 'a coordinate definition used for diagnostics. Each string '//& 'is of the form "MODULE_SUFFIX,PARAMETER_SUFFIX,COORDINATE_NAME".', & fail_if_missing=.true.) endif @@ -2246,8 +2944,8 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) 'Set the default missing value to use for diagnostics.', & default=1.e20) call get_param(param_file, mdl, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, & - 'Instead of writing diagnostics to the diag manager, write\n' //& - 'a textfile containing the checksum (bitcount) of the array.', & + 'Instead of writing diagnostics to the diag manager, write '//& + 'a text file containing the checksum (bitcount) of the array.', & default=.false.) ! Keep pointers grid, h, T, S needed diagnostic remapping @@ -2269,12 +2967,22 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) diag_cs%isd = G%isd ; diag_cs%ied = G%ied diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + !Downsample indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array) + diag_cs%dsamp(2)%isc = G%HId2%isc - (G%HId2%isd-1) ; diag_cs%dsamp(2)%iec = G%HId2%iec - (G%HId2%isd-1) + diag_cs%dsamp(2)%jsc = G%HId2%jsc - (G%HId2%jsd-1) ; diag_cs%dsamp(2)%jec = G%HId2%jec - (G%HId2%jsd-1) + diag_cs%dsamp(2)%isd = G%HId2%isd ; diag_cs%dsamp(2)%ied = G%HId2%ied + diag_cs%dsamp(2)%jsd = G%HId2%jsd ; diag_cs%dsamp(2)%jed = G%HId2%jed + diag_cs%dsamp(2)%isg = G%HId2%isg ; diag_cs%dsamp(2)%ieg = G%HId2%ieg + diag_cs%dsamp(2)%jsg = G%HId2%jsg ; diag_cs%dsamp(2)%jeg = G%HId2%jeg + diag_cs%dsamp(2)%isgB = G%HId2%isgB ; diag_cs%dsamp(2)%iegB = G%HId2%iegB + diag_cs%dsamp(2)%jsgB = G%HId2%jsgB ; diag_cs%dsamp(2)%jegB = G%HId2%jegB + ! Initialze available diagnostic log file if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then write(this_pe,'(i6.6)') PE_here() doc_file_dflt = "available_diags."//this_pe call get_param(param_file, mdl, "AVAILABLE_DIAGS_FILE", doc_file, & - "A file into which to write a list of all available \n"//& + "A file into which to write a list of all available "//& "ocean diagnostics that can be included in a diag_table.", & default=doc_file_dflt, do_not_log=(diag_CS%available_diag_doc_unit/=-1)) if (len_trim(doc_file) > 0) then @@ -2312,7 +3020,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) write(this_pe,'(i6.6)') PE_here() doc_file_dflt = "chksum_diag."//this_pe call get_param(param_file, mdl, "CHKSUM_DIAG_FILE", doc_file, & - "A file into which to write all checksums of the \n"//& + "A file into which to write all checksums of the "//& "diagnostics listed in the diag_table.", & default=doc_file_dflt, do_not_log=(diag_CS%chksum_diag_doc_unit/=-1)) if (len_trim(doc_file) > 0) then @@ -2459,6 +3167,9 @@ subroutine diag_masks_set(G, nz, diag_cs) diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:) enddo + !Allocate and initialize the downsampled masks + call downsample_diag_masks_set(G, nz, diag_cs) + end subroutine diag_masks_set subroutine diag_mediator_close_registration(diag_CS) @@ -2506,6 +3217,20 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) deallocate(diag_cs%mask3dBi) deallocate(diag_cs%mask3dCui) deallocate(diag_cs%mask3dCvi) + do i=2,MAX_DSAMP_LEV + deallocate(diag_cs%dsamp(i)%mask2dT) + deallocate(diag_cs%dsamp(i)%mask2dBu) + deallocate(diag_cs%dsamp(i)%mask2dCu) + deallocate(diag_cs%dsamp(i)%mask2dCv) + deallocate(diag_cs%dsamp(i)%mask3dTL) + deallocate(diag_cs%dsamp(i)%mask3dBL) + deallocate(diag_cs%dsamp(i)%mask3dCuL) + deallocate(diag_cs%dsamp(i)%mask3dCvL) + deallocate(diag_cs%dsamp(i)%mask3dTi) + deallocate(diag_cs%dsamp(i)%mask3dBi) + deallocate(diag_cs%dsamp(i)%mask3dCui) + deallocate(diag_cs%dsamp(i)%mask3dCvi) + enddo #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) deallocate(diag_cs%h_old) @@ -2762,4 +3487,634 @@ subroutine diag_grid_storage_end(grid_storage) deallocate(grid_storage%diag_grids) end subroutine diag_grid_storage_end +!< Allocate and initialize the masks for downsampled diagostics in diag_cs +!! The downsampled masks in the axes would later "point" to these. +subroutine downsample_diag_masks_set(G, nz, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + integer, intent(in) :: nz !< The number of layers in the model's native grid. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: i,j,k,ii,jj,dl + +!print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec +!print*,'original c extents ',G%iscb,G%iecb,G%jscb,G%jecb +!print*,'coarse c extents ',G%HId2%isc,G%HId2%iec,G%HId2%jsc,G%HId2%jec +!print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed +!print*,'coarse d extents ',G%HId2%isd,G%HId2%ied,G%HId2%jsd,G%HId2%jed +! original c extents 5 52 5 52 +! original cB-nonsym extents 5 52 5 52 +! original cB-sym extents 4 52 4 52 +! coarse c extents 3 26 3 26 +! original d extents 1 56 1 56 +! original dB-nonsym extents 1 56 1 56 +! original dB-sym extents 0 56 0 56 +! coarse d extents 1 28 1 28 + + do dl=2,MAX_DSAMP_LEV + ! 2d mask + call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,G%isc, G%jsc, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(G%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl,G%isc ,G%JscB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + ! 3d native masks are needed by diag_manager but the native variables + ! can only be masked 2d - for ocean points, all layers exists. + allocate(diag_cs%dsamp(dl)%mask3dTL(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dBL(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCuL(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCvL(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz)) + do k=1,nz + diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) + enddo + allocate(diag_cs%dsamp(dl)%mask3dTi(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dBi(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCui(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCvi(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + do k=1,nz+1 + diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCui(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvi(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) + enddo + enddo +end subroutine downsample_diag_masks_set + +!> Get the diagnostics-compute indices (to be passed to send_data) based on the shape of +!! the diag field (the same way they are deduced for non-downsampled fields) +subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev) + integer, intent(in) :: fo1 !< The size of the diag field in x + integer, intent(in) :: fo2 !< The size of the diag field in y + integer, intent(in) :: dl !< Integer downsample level + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + integer, intent(out) :: isv !< i-start index for diagnostics + integer, intent(out) :: iev !< i-end index for diagnostics + integer, intent(out) :: jsv !< j-start index for diagnostics + integer, intent(out) :: jev !< j-end index for diagnostics + ! Local variables + integer :: dszi,cszi,dszj,cszj,f1,f2 + character(len=500) :: mesg + logical, save :: first_check = .true. + + !Check ONCE that the downsampled diag-compute domain is commensurate with the original + !non-downsampled diag-compute domain. + !This is a major limitation of the current implementation of the downsampled diagnostics. + !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates. + !We want this check to error out only if there was a downsampled diagnostics requested and about to post that is + !why the check is here and not in the init routines. This check need to be done only once, hence the outer if. + if(first_check) then + if(mod(diag_cs%ie-diag_cs%is+1, dl) .ne. 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) .ne. 0) then + write (mesg,*) "Non-commensurate downsampled domain is not supported. "//& + "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl,& + " Current domain extents: ", diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif + first_check = .false. + endif + + cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1 + cszj = diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc +1 ; dszj = diag_cs%dsamp(dl)%jed-diag_cs%dsamp(dl)%jsd +1 + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec + f1 = fo1/dl + f2 = fo2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(fo1,dl) + f2 = f2 + mod(fo2,dl) + endif + if ( f1 == dszi ) then + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies + !The rest is not taken with the full MOM6 diag_table + elseif ( f1 == dszi + 1 ) then + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1 ! Symmetric data domain + elseif ( f1 == cszi) then + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +1 ! Computational domain + elseif ( f1 == cszi + 1 ) then + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",f1," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif + if ( f2 == dszj ) then + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec ! Data domain + elseif ( f2 == dszj + 1 ) then + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec+1 ! Symmetric data domain + elseif ( f2 == cszj) then + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +1 ! Computational domain + elseif ( f2 == cszj + 1 ) then + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",f2," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif +end subroutine downsample_diag_indices_get + +!> This subroutine allocates and computes a downsampled array from an input array +!! It also determines the diagnostics-compurte indices for the downsampled array +!! 3d interface +subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) + real, dimension(:,:,:), pointer :: locfield !< Input array pointer + real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: dl !< Level of down sampling + integer, intent(inout) :: isv !< i-start index for diagnostics + integer, intent(inout) :: iev !< i-end index for diagnostics + integer, intent(inout) :: jsv !< j-start index for diagnostics + integer, intent(inout) :: jev !< j-end index for diagnostics + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + ! Locals + real, dimension(:,:,:), pointer :: locmask + integer :: f1,f2,isv_o,jsv_o + + locmask => NULL() + !Get the correct indices corresponding to input field + !Shape of the input diag field + f1=size(locfield,1) + f2=size(locfield,2) + !Save the extents of the original (fine) domain + isv_o=isv;jsv_o=jsv + !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them + call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) + !Set the non-downsampled mask, it must be associated and initialized + if (present(mask)) then + locmask => mask + elseif (associated(diag%axes%mask3d)) then + locmask => diag%axes%mask3d + else + call MOM_error(FATAL, "downsample_diag_field_3d: Cannot downsample without a mask!!! ") + endif + + call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs, diag, & + isv_o,jsv_o,isv,iev,jsv,jev) + +end subroutine downsample_diag_field_3d + +!> This subroutine allocates and computes a downsampled array from an input array +!! It also determines the diagnostics-compurte indices for the downsampled array +!! 2d interface +subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) + real, dimension(:,:), pointer :: locfield !< Input array pointer + real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: dl !< Level of down sampling + integer, intent(inout) :: isv !< i-start index for diagnostics + integer, intent(inout) :: iev !< i-end index for diagnostics + integer, intent(inout) :: jsv !< j-start index for diagnostics + integer, intent(inout) :: jev !< j-end index for diagnostics + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + ! Locals + real, dimension(:,:), pointer :: locmask + integer :: f1,f2,isv_o,jsv_o + + locmask => NULL() + !Get the correct indices corresponding to input field + !Shape of the input diag field + f1=size(locfield,1) + f2=size(locfield,2) + !Save the extents of the original (fine) domain + isv_o=isv;jsv_o=jsv + !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them + call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) + !Set the non-downsampled mask, it must be associated and initialized + if (present(mask)) then + locmask => mask + elseif (associated(diag%axes%mask2d)) then + locmask => diag%axes%mask2d + else + call MOM_error(FATAL, "downsample_diag_field_2d: Cannot downsample without a mask!!! ") + endif + + call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, & + isv_o,jsv_o,isv,iev,jsv,jev) + +end subroutine downsample_diag_field_2d + +!> \section downsampling The down sample algorithm +!! +!! The down sample method could be deduced (before send_data call) +!! from the diag%x_cell_method, diag%y_cell_method and diag%v_cell_method +!! +!! This is the summary of the down sample algoritm for a diagnostic field f: +!! \f[ +!! f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)] +!! \f] +!! Here, i and j run from 0 to dl-1 (dl being the down sample level). +!! Id,Jd are the down sampled (coarse grid) indices run over the coarsened compute grid, +!! if and jf are the original (fine grid) indices. +!! +!! \verbatim +!! Example x_cell y_cell v_cell algorithm_id implemented weight(if,jf) +!! --------------------------------------------------------------------------------------- +!! theta mean mean mean MMM =222 G%areaT(if,jf)*h(if,jf) +!! u point mean mean PMM =022 dyCu(if,jf)*h(if,jf)*delta(if,Id) +!! v mean point mean MPM =202 dxCv(if,jf)*h(if,jf)*delta(jf,Jd) +!! ? point sum mean PSM =012 h(if,jf)*delta(if,Id) +!! volcello sum sum sum SSS =111 1 +!! T_dfxy_co sum sum point SSP =110 1 +!! umo point sum sum PSS =011 1*delta(if,Id) +!! vmo sum point sum SPS =101 1*delta(jf,Jd) +!! umo_2d point sum point PSP =010 1*delta(if,Id) +!! vmo_2d sum point point SPP =100 1*delta(jf,Jd) +!! ? point mean point PMP =020 dyCu(if,jf)*delta(if,Id) +!! ? mean point point MPP =200 dxCv(if,jf)*delta(jf,Jd) +!! w mean mean point MMP =220 G%areaT(if,jf) +!! h*theta mean mean sum MMS =221 G%areaT(if,jf) +!! +!! delta is the Kronecker delta +!! \endverbatim + +!> This subroutine allocates and computes a down sampled 3d array given an input array +!! The down sample method is based on the "cell_methods" for the diagnostics as explained +!! in the above table +subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) + real, dimension(:,:,:), pointer :: field_in !< Original field to be down sampled + real, dimension(:,:,:), allocatable :: field_out !< down sampled field + integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: method !< Sampling method + real, dimension(:,:,:), pointer :: mask !< Mask for field + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: isv_o !< Original i-start index + integer, intent(in) :: jsv_o !< Original j-start index + integer, intent(in) :: isv_d !< i-start index of down sampled data + integer, intent(in) :: iev_d !< i-end index of down sampled data + integer, intent(in) :: jsv_d !< j-start index of down sampled data + integer, intent(in) :: jev_d !< j-end index of down sampled data + ! Locals + character(len=240) :: mesg + integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 + integer :: k,ks,ke + real :: ave,total_weight,weight + real :: epsilon = 1.0e-20 + + ks=1 ; ke =size(field_in,3) + ! Allocate the down sampled field on the down sampled data domain +! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed,ks:ke)) +! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke)) + f_in1 = size(field_in,1) + f_in2 = size(field_in,2) + f1 = f_in1/dl + f2 = f_in2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) + endif + allocate(field_out(1:f1,1:f2,ks:ke)) + + ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain + if(method .eq. MMM) then + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!! + weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo; enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. SSS) then !e.g., volcello + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo; enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. MMP .or. method .eq. MMS) then !e.g., T_advection_xy + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo; enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. PMM) then + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj,k)*diag_cs%G%dyCu(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. PSM) then + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj,k)*diag_cs%h(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. PSS) then !e.g. umo + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. SPS) then !e.g. vmo + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight =mask(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. MPM) then + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj,k)*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. MSK) then !The input field is a mask, subsample + field_out(:,:,:) = 0.0 + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave=ave+field_in(ii,jj,k) + enddo; enddo + if(ave > 0.0) field_out(i,j,k)=1.0 + enddo; enddo; enddo + else + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_3d: "//trim(mesg)//" "//trim(diag%debug_str)) + endif + +end subroutine downsample_field_3d + +!> This subroutine allocates and computes a down sampled 2d array given an input array +!! The down sample method is based on the "cell_methods" for the diagnostics as explained +!! in the above table +subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, diag, & + isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d) + real, dimension(:,:), pointer :: field_in !< Original field to be down sampled + real, dimension(:,:), allocatable :: field_out !< Down sampled field + integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: method !< Sampling method + real, dimension(:,:), pointer :: mask !< Mask for field + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: isv_o !< Original i-start index + integer, intent(in) :: jsv_o !< Original j-start index + integer, intent(in) :: isv_d !< i-start index of down sampled data + integer, intent(in) :: iev_d !< i-end index of down sampled data + integer, intent(in) :: jsv_d !< j-start index of down sampled data + integer, intent(in) :: jev_d !< j-end index of down sampled data + ! Locals + character(len=240) :: mesg + integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 + real :: ave,total_weight,weight + real :: epsilon = 1.0e-20 + + ! Allocate the down sampled field on the down sampled data domain +! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed)) +! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl)) + ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain + f_in1 = size(field_in,1) + f_in2 = size(field_in,2) + f1 = f_in1/dl + f2 = f_in2/dl + ! Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) + endif + allocate(field_out(1:f1,1:f2)) + + if(method .eq. MMP) then + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj)*weight + enddo; enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. SSP) then ! e.g., T_dfxy_cont_tendency_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj)*weight + enddo; enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. PSP) then ! e.g., umo_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. SPP) then ! e.g., vmo_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight =mask(ii,jj) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. PMP) then + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj)*diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. MPP) then + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight =mask(ii,jj)*diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. MSK) then !The input field is a mask, subsample + field_out(:,:) = 0.0 + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave=ave+field_in(ii,jj) + enddo; enddo + if(ave > 0.0) field_out(i,j)=1.0 + enddo; enddo + else + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_2d: "//trim(mesg)//" "//trim(diag%debug_str)) + endif + +end subroutine downsample_field_2d + +!> Allocate and compute the 2d down sampled mask +!! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) +!! if at least one of the sub-cells are open, otherwise it's closed (0) +subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, & + isd_d, ied_d, jsd_d, jed_d) + real, dimension(:,:), intent(in) :: field_in !< Original field to be down sampled + real, dimension(:,:), pointer :: field_out !< Down sampled field + integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: isc_o !< Original i-start index + integer, intent(in) :: jsc_o !< Original j-start index + integer, intent(in) :: isc_d !< Computational i-start index of down sampled data + integer, intent(in) :: iec_d !< Computational i-end index of down sampled data + integer, intent(in) :: jsc_d !< Computational j-start index of down sampled data + integer, intent(in) :: jec_d !< Computational j-end index of down sampled data + integer, intent(in) :: isd_d !< Computational i-start index of down sampled data + integer, intent(in) :: ied_d !< Computational i-end index of down sampled data + integer, intent(in) :: jsd_d !< Computational j-start index of down sampled data + integer, intent(in) :: jed_d !< Computational j-end index of down sampled data + ! Locals + integer :: i,j,ii,jj,i0,j0 + real :: tot_non_zero + ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1 + allocate(field_out(isd_d:ied_d,jsd_d:jed_d)) + field_out(:,:) = 0.0 + do j=jsc_d,jec_d ; do i=isc_d,iec_d + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) + tot_non_zero = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + tot_non_zero = tot_non_zero + field_in(ii,jj) + enddo;enddo + if(tot_non_zero > 0.0) field_out(i,j)=1.0 + enddo; enddo +end subroutine downsample_mask_2d + +!> Allocate and compute the 3d down sampled mask +!! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) +!! if at least one of the sub-cells are open, otherwise it's closed (0) +subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, & + isd_d, ied_d, jsd_d, jed_d) + real, dimension(:,:,:), intent(in) :: field_in !< Original field to be down sampled + real, dimension(:,:,:), pointer :: field_out !< down sampled field + integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: isc_o !< Original i-start index + integer, intent(in) :: jsc_o !< Original j-start index + integer, intent(in) :: isc_d !< Computational i-start index of down sampled data + integer, intent(in) :: iec_d !< Computational i-end index of down sampled data + integer, intent(in) :: jsc_d !< Computational j-start index of down sampled data + integer, intent(in) :: jec_d !< Computational j-end index of down sampled data + integer, intent(in) :: isd_d !< Computational i-start index of down sampled data + integer, intent(in) :: ied_d !< Computational i-end index of down sampled data + integer, intent(in) :: jsd_d !< Computational j-start index of down sampled data + integer, intent(in) :: jed_d !< Computational j-end index of down sampled data + ! Locals + integer :: i,j,ii,jj,i0,j0,k,ks,ke + real :: tot_non_zero + ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1 + ks = lbound(field_in,3) ; ke = ubound(field_in,3) + allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke)) + field_out(:,:,:) = 0.0 + do k= ks,ke ; do j=jsc_d,jec_d ; do i=isc_d,iec_d + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) + tot_non_zero = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + tot_non_zero = tot_non_zero + field_in(ii,jj,k) + enddo;enddo + if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 + enddo; enddo; enddo +end subroutine downsample_mask_3d + end module MOM_diag_mediator + diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 36f43528be..75496544db 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -40,6 +40,7 @@ module MOM_document logical :: defineSyntax = .false. !< If true, use '\#def' syntax instead of a=b syntax logical :: warnOnConflicts = .false. !< Cause a WARNING error if defaults differ. integer :: commentColumn = 32 !< Number of spaces before the comment marker. + integer :: max_line_len = 112 !< The maximum length of message lines. type(link_msg), pointer :: chain_msg => NULL() !< Database of messages character(len=240) :: blockPrefix = '' !< The full name of the current block. end type doc_type @@ -457,9 +458,16 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & integer, optional, intent(in) :: indent !< An amount by which to indent this message logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. - character(len=mLen) :: mesg - integer :: start_ind = 1, end_ind, indnt, tab, len_tab, len_nl - logical :: all, short, layout, debug + + ! Local variables + character(len=mLen) :: mesg ! A full line of a message including indents. + character(len=mLen) :: mesg_text ! A line of message text without preliminary indents. + integer :: start_ind = 1 ! The starting index in the description for the next line. + integer :: nl_ind, tab_ind, end_ind ! The indices of new-lines, tabs, and the end of a line. + integer :: len_text, len_tab, len_nl ! The lengths of the text string, tabs and new-lines. + integer :: indnt, msg_pad ! Space counts used to format a message. + logical :: msg_done, reset_msg_pad ! Logicals used to format messages. + logical :: all, short, layout, debug ! Flags indicating which files to write into. layout = .false. ; if (present(layoutParam)) layout = layoutParam debug = .false. ; if (present(debuggingParam)) debug = debuggingParam @@ -475,41 +483,64 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & if (len_trim(desc) == 0) return len_tab = len_trim("_\t_") - 2 - len_nl = len_trim("_\n_") -2 + len_nl = len_trim("_\n_") - 2 indnt = doc%commentColumn ; if (present(indent)) indnt = indent - start_ind = 1 + len_text = doc%max_line_len - (indnt + 2) + start_ind = 1 ; msg_pad = 0 ; msg_done = .false. do if (len_trim(desc(start_ind:)) < 1) exit - end_ind = index(desc(start_ind:), "\n") + nl_ind = index(desc(start_ind:), "\n") - if (end_ind > 0) then - mesg = repeat(" ",indnt)//"! "//trim(desc(start_ind:start_ind+end_ind-2)) - start_ind = start_ind + end_ind - 1 + len_nl + end_ind = 0 + if ((nl_ind > 0) .and. (len_trim(desc(start_ind:start_ind+nl_ind-2)) > len_text-msg_pad)) then + ! This line is too long despite the new-line character. Look for an earlier space to break. + end_ind = scan(desc(start_ind:start_ind+(len_text-msg_pad)), " ", back=.true.) - 1 + if (end_ind > 0) nl_ind = 0 + elseif ((nl_ind == 0) .and. (len_trim(desc(start_ind:)) > len_text-msg_pad)) then + ! This line is too long and does not have a new-line character. Look for a space to break. + end_ind = scan(desc(start_ind:start_ind+(len_text-msg_pad)), " ", back=.true.) - 1 + endif - do ; tab = index(mesg, "\t") - if (tab == 0) exit - mesg(tab:) = " "//trim(mesg(tab+len_tab:)) - enddo - if (all) write(doc%unitAll, '(a)') trim(mesg) - if (short) write(doc%unitShort, '(a)') trim(mesg) - if (layout) write(doc%unitLayout, '(a)') trim(mesg) - if (debug) write(doc%unitDebugging, '(a)') trim(mesg) + reset_msg_pad = .false. + if (nl_ind > 0) then + mesg_text = trim(desc(start_ind:start_ind+nl_ind-2)) + start_ind = start_ind + nl_ind + len_nl - 1 + reset_msg_pad = .true. + elseif (end_ind > 0) then + mesg_text = trim(desc(start_ind:start_ind+end_ind)) + start_ind = start_ind + end_ind + 1 + ! Adjust the starting point to move past leading spaces. + start_ind = start_ind + (len_trim(desc(start_ind:)) - len_trim(adjustl(desc(start_ind:)))) else - mesg = repeat(" ",indnt)//"! "//trim(desc(start_ind:)) - do ; tab = index(mesg, "\t") - if (tab == 0) exit - mesg(tab:) = " "//trim(mesg(tab+len_tab:)) - enddo - if (all) write(doc%unitAll, '(a)') trim(mesg) - if (short) write(doc%unitShort, '(a)') trim(mesg) - if (layout) write(doc%unitLayout, '(a)') trim(mesg) - if (debug) write(doc%unitDebugging, '(a)') trim(mesg) - exit + mesg_text = trim(desc(start_ind:)) + msg_done = .true. endif + do ; tab_ind = index(mesg_text, "\t") ! Replace \t with 2 spaces. + if (tab_ind == 0) exit + mesg_text(tab_ind:) = " "//trim(mesg_text(tab_ind+len_tab:)) + enddo + + mesg = repeat(" ",indnt)//"! "//repeat(" ",msg_pad)//trim(mesg_text) + + if (reset_msg_pad) then + msg_pad = 0 + elseif (msg_pad == 0) then ! Indent continuation lines. + msg_pad = len_trim(mesg_text) - len_trim(adjustl(mesg_text)) + ! If already indented, indent an additional 2 spaces. + if (msg_pad >= 2) msg_pad = msg_pad + 2 + endif + + if (all) write(doc%unitAll, '(a)') trim(mesg) + if (short) write(doc%unitShort, '(a)') trim(mesg) + if (layout) write(doc%unitLayout, '(a)') trim(mesg) + if (debug) write(doc%unitDebugging, '(a)') trim(mesg) + + if (msg_done) exit enddo + end subroutine writeMessageAndDesc ! ---------------------------------------------------------------------- diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 417274500d..64fddfe7fc 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -32,7 +32,7 @@ module MOM_domains implicit none ; private -public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent +public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent, get_domain_extent_dsamp2 public :: MOM_define_domain, MOM_define_io_domain, clone_MOM_domain public :: pass_var, pass_vector, PE_here, root_PE, num_PEs public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast @@ -99,6 +99,8 @@ module MOM_domains type, public :: MOM_domain_type 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. @@ -1204,7 +1206,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & character(len=8) :: char_xsiz, char_ysiz, char_niglobal, char_njglobal character(len=40) :: nihalo_nm, njhalo_nm, layout_nm, io_layout_nm, masktable_nm character(len=40) :: niproc_nm, njproc_nm - + integer :: xhalo_d2,yhalo_d2 ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -1212,6 +1214,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) endif pe = PE_here() @@ -1264,7 +1267,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "If true, the domain is meridionally reentrant.", & default=.false.) call get_param(param_file, mdl, "TRIPOLAR_N", tripolar_N, & - "Use tripolar connectivity at the northern edge of the \n"//& + "Use tripolar connectivity at the northern edge of the "//& "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & default=.false.) @@ -1304,19 +1307,19 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ endif #endif call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", MOM_dom%symmetric, & - "If defined, the velocity point data domain includes \n"//& - "every face of the thickness points. In other words, \n"//& - "some arrays are larger than others, depending on where \n"//& - "they are on the staggered grid. Also, the starting \n"//& - "index of the velocity-point arrays is usually 0, not 1. \n"//& + "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.",& layoutParam=.true.) call get_param(param_file, mdl, "NONBLOCKING_UPDATES", MOM_dom%nonblocking_updates, & "If true, non-blocking halo updates may be used.", & default=.false., layoutParam=.true.) call get_param(param_file, mdl, "THIN_HALO_UPDATES", MOM_dom%thin_halo_updates, & - "If true, optional arguments may be used to specify the \n"//& - "The width of the halos that are updated with each call.", & + "If true, optional arguments may be used to specify the "//& + "the width of the halos that are updated with each call.", & default=.true., layoutParam=.true.) nihalo_dflt = 4 ; njhalo_dflt = 4 @@ -1324,24 +1327,24 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (present(NJHALO)) njhalo_dflt = NJHALO call log_param(param_file, mdl, "!STATIC_MEMORY_", is_static, & - "If STATIC_MEMORY_ is defined, the principle variables \n"//& - "will have sizes that are statically determined at \n"//& - "compile time. Otherwise the sizes are not determined \n"//& - "until run time. The STATIC option is substantially \n"//& - "faster, but does not allow the PE count to be changed \n"//& + "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.",& layoutParam=.true.) call get_param(param_file, mdl, trim(nihalo_nm), MOM_dom%nihalo, & - "The number of halo points on each side in the \n"//& - "x-direction. With STATIC_MEMORY_ this is set as NIHALO_ \n"//& - "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ \n"//& + "The number of halo points on each side in the "//& + "x-direction. With STATIC_MEMORY_ this is set as NIHALO_ "//& + "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ "//& "the default is NIHALO_ in "//trim(inc_nm)//" (if defined) or 2.", & default=4, static_value=nihalo_dflt, layoutParam=.true.) call get_param(param_file, mdl, trim(njhalo_nm), MOM_dom%njhalo, & - "The number of halo points on each side in the \n"//& - "y-direction. With STATIC_MEMORY_ this is set as NJHALO_ \n"//& - "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ \n"//& + "The number of halo points on each side in the "//& + "y-direction. With STATIC_MEMORY_ this is set as NJHALO_ "//& + "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ "//& "the default is NJHALO_ in "//trim(inc_nm)//" (if defined) or 2.", & default=4, static_value=njhalo_dflt, layoutParam=.true.) if (present(min_halo)) then @@ -1354,13 +1357,13 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif if (is_static) then call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & - "The total number of thickness grid points in the \n"//& - "x-direction in the physical domain. With STATIC_MEMORY_ \n"//& + "The total number of thickness grid points in the "//& + "x-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & static_value=NIGLOBAL) call get_param(param_file, mdl, "NJGLOBAL", MOM_dom%njglobal, & - "The total number of thickness grid points in the \n"//& - "y-direction in the physical domain. With STATIC_MEMORY_ \n"//& + "The total number of thickness grid points in the "//& + "y-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & static_value=NJGLOBAL) if (MOM_dom%niglobal /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & @@ -1376,13 +1379,13 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif else call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & - "The total number of thickness grid points in the \n"//& - "x-direction in the physical domain. With STATIC_MEMORY_ \n"//& + "The total number of thickness grid points in the "//& + "x-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & fail_if_missing=.true.) call get_param(param_file, mdl, "NJGLOBAL", MOM_dom%njglobal, & - "The total number of thickness grid points in the \n"//& - "y-direction in the physical domain. With STATIC_MEMORY_ \n"//& + "The total number of thickness grid points in the "//& + "y-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & fail_if_missing=.true.) endif @@ -1394,15 +1397,15 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & inputdir = slasher(inputdir) call get_param(param_file, mdl, trim(masktable_nm), mask_table, & - "A text file to specify n_mask, layout and mask_list. \n"//& - "This feature masks out processors that contain only land points. \n"//& - "The first line of mask_table is the number of regions to be masked out.\n"//& - "The second line is the layout of the model and must be \n"//& - "consistent with the actual model layout.\n"//& - "The following (n_mask) lines give the logical positions \n"//& - "of the processors that are masked out. The mask_table \n"//& - "can be created by tools like check_mask. The \n"//& - "following example of mask_table masks out 2 processors, \n"//& + "A text file to specify n_mask, layout and mask_list. "//& + "This feature masks out processors that contain only land points. "//& + "The first line of mask_table is the number of regions to be masked out. "//& + "The second line is the layout of the model and must be "//& + "consistent with the actual model layout. "//& + "The following (n_mask) lines give the logical positions "//& + "of the processors that are masked out. The mask_table "//& + "can be created by tools like check_mask. The "//& + "following example of mask_table masks out 2 processors, "//& "(1,2) and (3,6), out of the 24 in a 4x6 layout: \n"//& " 2\n 4,6\n 1,2\n 3,6\n", default="MOM_mask_table", & layoutParam=.true.) @@ -1413,7 +1416,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & layout(1) = NIPROC ; layout(2) = NJPROC else call get_param(param_file, mdl, trim(layout_nm), layout, & - "The processor layout to be used, or 0, 0 to automatically \n"//& + "The processor layout to be used, or 0, 0 to automatically "//& "set the layout based on the number of processors.", default=0, & do_not_log=.true.) call get_param(param_file, mdl, trim(niproc_nm), nip_parsed, & @@ -1452,11 +1455,11 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif endif call log_param(param_file, mdl, trim(niproc_nm), layout(1), & - "The number of processors in the x-direction. With \n"//& + "The number of processors in the x-direction. With "//& "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& layoutParam=.true.) call log_param(param_file, mdl, trim(njproc_nm), layout(2), & - "The number of processors in the y-direction. With \n"//& + "The number of processors in the y-direction. With "//& "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& layoutParam=.true.) call log_param(param_file, mdl, trim(layout_nm), layout, & @@ -1481,7 +1484,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! number of PEs in each direction. io_layout(:) = (/ 1, 1 /) call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & - "The processor layout to be used, or 0,0 to automatically \n"//& + "The processor layout to be used, or 0,0 to automatically "//& "set the io_layout to be the same as the layout.", default=1, & layoutParam=.true.) @@ -1566,6 +1569,31 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif endif + global_indices(1) = 1 ; global_indices(2) = int(MOM_dom%niglobal/2) + global_indices(3) = 1 ; global_indices(4) = int(MOM_dom%njglobal/2) + !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 + xhalo_d2 = int(MOM_dom%nihalo/2) + yhalo_d2 = int(MOM_dom%njhalo/2) + if (mask_table_exists) then + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=xhalo_d2, yhalo=yhalo_d2, & + symmetry = MOM_dom%symmetric, name=trim("MOMc"), & + maskmap=MOM_dom%maskmap ) + else + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=xhalo_d2, yhalo=yhalo_d2, & + symmetry = MOM_dom%symmetric, name=trim("MOMc")) + endif + + if ((io_layout(1) > 0) .and. (io_layout(2) > 0) .and. & + (layout(1)*layout(2) > 1)) then + call MOM_define_io_domain(MOM_dom%mpp_domain_d2, io_layout) + endif + end subroutine MOM_domains_init !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing @@ -1597,6 +1625,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & 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 @@ -1792,6 +1821,34 @@ subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & end subroutine get_domain_extent +subroutine get_domain_extent_dsamp2(Domain, isc_d2, iec_d2, jsc_d2, jec_d2,& + isd_d2, ied_d2, jsd_d2, jed_d2,& + isg_d2, ieg_d2, jsg_d2, jeg_d2) + type(MOM_domain_type), & + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc_d2 !< The start i-index of the computational domain + integer, intent(out) :: iec_d2 !< The end i-index of the computational domain + integer, intent(out) :: jsc_d2 !< The start j-index of the computational domain + integer, intent(out) :: jec_d2 !< The end j-index of the computational domain + integer, intent(out) :: isd_d2 !< The start i-index of the data domain + integer, intent(out) :: ied_d2 !< The end i-index of the data domain + integer, intent(out) :: jsd_d2 !< The start j-index of the data domain + integer, intent(out) :: jed_d2 !< The end j-index of the data domain + integer, intent(out) :: isg_d2 !< The start i-index of the global domain + integer, intent(out) :: ieg_d2 !< The end i-index of the global domain + integer, intent(out) :: jsg_d2 !< The start j-index of the global domain + integer, intent(out) :: jeg_d2 !< The end j-index of the global domain + + call mpp_get_compute_domain(Domain%mpp_domain_d2, isc_d2, iec_d2, jsc_d2, jec_d2) + call mpp_get_data_domain(Domain%mpp_domain_d2, isd_d2, ied_d2, jsd_d2, jed_d2) + call mpp_get_global_domain (Domain%mpp_domain_d2, isg_d2, ieg_d2, jsg_d2, jeg_d2) + ! This code institutes the MOM convention that local array indices start at 1. + isc_d2 = isc_d2-isd_d2+1 ; iec_d2 = iec_d2-isd_d2+1 + jsc_d2 = jsc_d2-jsd_d2+1 ; jec_d2 = jec_d2-jsd_d2+1 + ied_d2 = ied_d2-isd_d2+1 ; jed_d2 = jed_d2-jsd_d2+1 + isd_d2 = 1 ; jsd_d2 = 1 +end subroutine get_domain_extent_dsamp2 + !> 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) diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 11155d73e6..0a83ef983e 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -148,10 +148,10 @@ module MOM_dyn_horgrid Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m]. Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m]. real, allocatable, dimension(:,:) :: & - CoriolisBu !< The Coriolis parameter at corner points [s-1]. + CoriolisBu !< The Coriolis parameter at corner points [T-1 ~> s-1]. real, allocatable, dimension(:,:) :: & - df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [s-1 m-1]. - df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [s-1 m-1]. + df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [T-1 m-1 ~> s-1 m-1]. + df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [T-1 m-1 ~> s-1 m-1]. ! These variables are global sums that are useful for 1-d diagnostics real :: areaT_global !< Global sum of h-cell area [m2] diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 5c80fb9d51..1d1e153ab9 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -275,26 +275,26 @@ subroutine close_param_file(CS, quiet_close, component) "If true, all log messages are also sent to stdout.", & default=log_to_stdout_default) call log_param(CS, mdl, "REPORT_UNUSED_PARAMS", CS%report_unused, & - "If true, report any parameter lines that are not used \n"//& + "If true, report any parameter lines that are not used "//& "in the run.", default=report_unused_default, & debuggingParam=.true.) call log_param(CS, mdl, "FATAL_UNUSED_PARAMS", CS%unused_params_fatal, & - "If true, kill the run if there are any unused \n"//& + "If true, kill the run if there are any unused "//& "parameters.", default=unused_params_fatal_default, & debuggingParam=.true.) docfile_default = "MOM_parameter_doc" if (present(component)) docfile_default = trim(component)//"_parameter_doc" call log_param(CS, mdl, "DOCUMENT_FILE", CS%doc_file, & - "The basename for files where run-time parameters, their\n"//& - "settings, units and defaults are documented. Blank will\n"//& + "The basename for files where run-time parameters, their "//& + "settings, units and defaults are documented. Blank will "//& "disable all parameter documentation.", default=docfile_default) if (len_trim(CS%doc_file) > 0) then call log_param(CS, mdl, "COMPLETE_DOCUMENTATION", CS%complete_doc, & - "If true, all run-time parameters are\n"//& + "If true, all run-time parameters are "//& "documented in "//trim(CS%doc_file)//& ".all .", default=complete_doc_default) call log_param(CS, mdl, "MINIMAL_DOCUMENTATION", CS%minimal_doc, & - "If true, non-default run-time parameters are\n"//& + "If true, non-default run-time parameters are "//& "documented in "//trim(CS%doc_file)//& ".short .", default=minimal_doc_default) endif diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 4d89dccc7b..c3819fc865 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -25,6 +25,7 @@ module MOM_restart public restart_init, restart_end, restore_state, register_restart_field public save_restart, query_initialized, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run +public register_restart_field_as_obsolete !> A type for making arrays of pointers to 4-d arrays type p4d @@ -61,11 +62,18 @@ module MOM_restart character(len=32) :: var_name !< A name by which a variable may be queried. end type field_restart +!> A structure to store information about restart fields that are no longer used +type obsolete_restart + character(len=32) :: field_name !< Name of restart field that is no longer in use + character(len=32) :: replacement_name !< Name of replacement restart field, if applicable +end type obsolete_restart + !> A restart registry and the control structure for restarts type, public :: MOM_restart_CS ; private logical :: restart !< restart is set to .true. if the run has been started from a full restart !! file. Otherwise some fields must be initialized approximately. integer :: novars = 0 !< The number of restart fields that have been registered. + integer :: num_obsolete_vars = 0 !< The number of obsolete restart fields that have been registered. logical :: parallel_restartfiles !< If true, each PE writes its own restart file, !! otherwise they are combined internally. logical :: large_file_support !< If true, NetCDF 3.6 or later is being used @@ -82,6 +90,9 @@ module MOM_restart !> An array of descriptions of the registered fields type(field_restart), pointer :: restart_field(:) => NULL() + !> An array of obsolete restart fields + type(obsolete_restart), pointer :: restart_obsolete(:) => NULL() + !>@{ Pointers to the fields that have been registered for restarts type(p0d), pointer :: var_ptr0d(:) => NULL() type(p1d), pointer :: var_ptr1d(:) => NULL() @@ -112,6 +123,16 @@ module MOM_restart end interface contains +!!> Register a restart field as obsolete +subroutine register_restart_field_as_obsolete(field_name, replacement_name, CS) + character(*), intent(in) :: field_name !< Name of restart field that is no longer in use + character(*), intent(in) :: replacement_name !< Name of replacement restart field, if applicable + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + + CS%num_obsolete_vars = CS%num_obsolete_vars+1 + CS%restart_obsolete(CS%num_obsolete_vars)%field_name = field_name + CS%restart_obsolete(CS%num_obsolete_vars)%replacement_name = replacement_name +end subroutine register_restart_field_as_obsolete !> Register a 3-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) @@ -1062,6 +1083,17 @@ subroutine restore_state(filename, directory, day, G, CS) allocate(fields(nvar)) call get_file_fields(unit(n),fields(1:nvar)) + do m=1, nvar + call get_file_atts(fields(m),name=varname) + do i=1,CS%num_obsolete_vars + if (adjustl(lowercase(trim(varname))) == adjustl(lowercase(trim(CS%restart_obsolete(i)%field_name)))) then + call MOM_error(FATAL, "MOM_restart restore_state: Attempting to use obsolete restart field "//& + trim(varname)//" - the new corresponding restart field is "//& + trim(CS%restart_obsolete(i)%replacement_name)) + endif + enddo + enddo + missing_fields = 0 do m=1,CS%novars @@ -1407,7 +1439,7 @@ subroutine restart_init(param_file, CS, restart_root) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", & CS%parallel_restartfiles, & - "If true, each processor writes its own restart file, \n"//& + "If true, each processor writes its own restart file, "//& "otherwise a single restart file is generated", & default=.false.) @@ -1419,20 +1451,21 @@ subroutine restart_init(param_file, CS, restart_root) "The name-root of the restart file.", default="MOM.res") endif call get_param(param_file, mdl, "LARGE_FILE_SUPPORT", CS%large_file_support, & - "If true, use the file-size limits with NetCDF large \n"//& + "If true, use the file-size limits with NetCDF large "//& "file support (4Gb), otherwise the limit is 2Gb.", & default=.true.) call get_param(param_file, mdl, "MAX_FIELDS", CS%max_fields, & "The maximum number of restart fields that can be used.", & default=100) call get_param(param_file, mdl, "RESTART_CHECKSUMS_REQUIRED", CS%checksum_required, & - "If true, require the restart checksums to match and error out otherwise. \n"//& - "Users may want to avoid this comparison if for example the restarts are \n"//& - "made from a run with a different mask_table than the current run, \n"//& + "If true, require the restart checksums to match and error out otherwise. "//& + "Users may want to avoid this comparison if for example the restarts are "//& + "made from a run with a different mask_table than the current run, "//& "in which case the checksums will not match and cause crash.",& default=.true.) allocate(CS%restart_field(CS%max_fields)) + allocate(CS%restart_obsolete(CS%max_fields)) allocate(CS%var_ptr0d(CS%max_fields)) allocate(CS%var_ptr1d(CS%max_fields)) allocate(CS%var_ptr2d(CS%max_fields)) @@ -1456,6 +1489,7 @@ subroutine restart_end(CS) type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object if (associated(CS%restart_field)) deallocate(CS%restart_field) + if (associated(CS%restart_obsolete)) deallocate(CS%restart_obsolete) if (associated(CS%var_ptr0d)) deallocate(CS%var_ptr0d) if (associated(CS%var_ptr1d)) deallocate(CS%var_ptr1d) if (associated(CS%var_ptr2d)) deallocate(CS%var_ptr2d) diff --git a/src/framework/MOM_safe_alloc.F90 b/src/framework/MOM_safe_alloc.F90 index 75f5fda74e..47dd8376a3 100644 --- a/src/framework/MOM_safe_alloc.F90 +++ b/src/framework/MOM_safe_alloc.F90 @@ -10,13 +10,14 @@ module MOM_safe_alloc !> Allocate a pointer to a 1-d, 2-d or 3-d array interface safe_alloc_ptr - module procedure safe_alloc_ptr_3d_2arg, safe_alloc_ptr_2d_2arg + module procedure safe_alloc_ptr_3d_3arg, safe_alloc_ptr_3d_6arg, safe_alloc_ptr_2d_2arg module procedure safe_alloc_ptr_3d, safe_alloc_ptr_2d, safe_alloc_ptr_1d end interface safe_alloc_ptr !> Allocate a 2-d or 3-d allocatable array interface safe_alloc_alloc module procedure safe_alloc_allocatable_3d, safe_alloc_allocatable_2d + module procedure safe_alloc_allocatable_3d_6arg end interface safe_alloc_alloc ! This combined interface might work with a later version of Fortran, but @@ -57,7 +58,7 @@ subroutine safe_alloc_ptr_2d_2arg(ptr, ni, nj) end subroutine safe_alloc_ptr_2d_2arg !> Allocate a pointer to a 3-d array based on its dimension sizes -subroutine safe_alloc_ptr_3d_2arg(ptr, ni, nj, nk) +subroutine safe_alloc_ptr_3d_3arg(ptr, ni, nj, nk) real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate integer, intent(in) :: ni !< The size of the 1st dimension of the array integer, intent(in) :: nj !< The size of the 2nd dimension of the array @@ -66,7 +67,7 @@ subroutine safe_alloc_ptr_3d_2arg(ptr, ni, nj, nk) allocate(ptr(ni,nj,nk)) ptr(:,:,:) = 0.0 endif -end subroutine safe_alloc_ptr_3d_2arg +end subroutine safe_alloc_ptr_3d_3arg !> Allocate a pointer to a 2-d array based on its index starting and ending values subroutine safe_alloc_ptr_2d(ptr, is, ie, js, je) @@ -95,6 +96,22 @@ subroutine safe_alloc_ptr_3d(ptr, is, ie, js, je, nk) endif end subroutine safe_alloc_ptr_3d +!> Allocate a pointer to a 3-d array based on its index starting and ending values +subroutine safe_alloc_ptr_3d_6arg(ptr, is, ie, js, je, ks, ke) + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: ks !< The start index to allocate for the 3rd dimension + integer, intent(in) :: ke !< The end index to allocate for the 3rd dimension + if (.not.associated(ptr)) then + allocate(ptr(is:ie,js:je,ks:ke)) + ptr(:,:,:) = 0.0 + endif +end subroutine safe_alloc_ptr_3d_6arg + + !> Allocate a 2-d allocatable array based on its index starting and ending values subroutine safe_alloc_allocatable_2d(ptr, is, ie, js, je) real, dimension(:,:), allocatable :: ptr !< An allocatable array to allocate @@ -109,6 +126,7 @@ subroutine safe_alloc_allocatable_2d(ptr, is, ie, js, je) end subroutine safe_alloc_allocatable_2d !> Allocate a 3-d allocatable array based on its index starting and ending values +!! and k-index size subroutine safe_alloc_allocatable_3d(ptr, is, ie, js, je, nk) real, dimension(:,:,:), allocatable :: ptr !< An allocatable array to allocate integer, intent(in) :: is !< The start index to allocate for the 1st dimension @@ -122,4 +140,19 @@ subroutine safe_alloc_allocatable_3d(ptr, is, ie, js, je, nk) endif end subroutine safe_alloc_allocatable_3d +!> Allocate a 3-d allocatable array based on its 6 index starting and ending values +subroutine safe_alloc_allocatable_3d_6arg(ptr, is, ie, js, je, ks, ke) + real, dimension(:,:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: ks !< The start index to allocate for the 3rd dimension + integer, intent(in) :: ke !< The end index to allocate for the 3rd dimension + if (.not.allocated(ptr)) then + allocate(ptr(is:ie,js:je,ks:ke)) + ptr(:,:,:) = 0.0 + endif +end subroutine safe_alloc_allocatable_3d_6arg + end module MOM_safe_alloc diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 60b07c1fbd..ca174025bf 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -58,15 +58,15 @@ subroutine unit_scaling_init( param_file, US ) call log_version(param_file, mdl, version, & "Parameters for doing unit scaling of variables.") call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & - "An integer power of 2 that is used to rescale the model's \n"//& + "An integer power of 2 that is used to rescale the model's "//& "intenal units of depths and heights. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & - "An integer power of 2 that is used to rescale the model's \n"//& + "An integer power of 2 that is used to rescale the model's "//& "intenal units of lateral distances. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & - "An integer power of 2 that is used to rescale the model's \n"//& + "An integer power of 2 that is used to rescale the model's "//& "intenal units of time. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index c85e3ecb7b..7a2fb36608 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -73,13 +73,13 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, & - "The maximum amount of cpu time per processor for which \n"//& - "MOM should run before saving a restart file and \n"//& - "quitting with a return value that indicates that a \n"//& - "further run is required to complete the simulation. \n"//& - "If automatic restarts are not desired, use a negative \n"//& - "value for MAXCPU. MAXCPU has units of wall-clock \n"//& - "seconds, so the actual CPU time used is larger by a \n"//& + "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.", & units="wall-clock seconds", default=-1.0) call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, & diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index fa4d2b0581..5020a4cbe7 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -375,8 +375,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Estimate the neutral ocean boundary layer thickness as the minimum of the ! reported ocean mixed layer thickness and the neutral Ekman depth. - absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & - (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + absf = 0.25*US%s_to_T*((abs(US%s_to_T*G%CoriolisBu(I,J)) + abs(US%s_to_T*G%CoriolisBu(I-1,J-1))) + & + (abs(US%s_to_T*G%CoriolisBu(I,J-1)) + abs(US%s_to_T*G%CoriolisBu(I-1,J)))) if (absf*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = state%Hml(i,j) else ; hBL_neut = (VK*ustar_h) / absf ; endif hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%Kv_molec)) @@ -1170,15 +1170,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl default=.false.) if (shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", CS%override_shelf_movement, & - "If true, user provided code specifies the ice-shelf \n"//& + "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false.) CS%active_shelf_dynamics = .not.CS%override_shelf_movement call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & - "If true, regularize the floatation condition at the \n"//& + "If true, regularize the floatation condition at the "//& "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & - "If true, let the floatation condition be determined by \n"//& - "ocean column thickness. This means that update_OD_ffrac \n"//& + "If true, let the floatation condition be determined by "//& + "ocean column thickness. This means that update_OD_ffrac "//& "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. @@ -1188,24 +1188,24 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "If true, use a thermodynamically interactive ice shelf.", & default=.false.) call get_param(param_file, mdl, "SHELF_THREE_EQN", CS%threeeq, & - "If true, use the three equation expression of \n"//& - "consistency to calculate the fluxes at the ice-ocean \n"//& + "If true, use the three equation expression of "//& + "consistency to calculate the fluxes at the ice-ocean "//& "interface.", default=.true.) call get_param(param_file, mdl, "SHELF_INSULATOR", CS%insulator, & - "If true, the ice shelf is a perfect insulatior \n"//& + "If true, the ice shelf is a perfect insulatior "//& "(no conduction).", default=.false.) call get_param(param_file, mdl, "MELTING_CUTOFF_DEPTH", CS%cutoff_depth, & - "Depth above which the melt is set to zero (it must be >= 0) \n"//& + "Depth above which the melt is set to zero (it must be >= 0) "//& "Default value won't affect the solution.", default=0.0) if (CS%cutoff_depth < 0.) & call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") call get_param(param_file, mdl, "CONST_SEA_LEVEL", CS%constant_sea_level, & - "If true, apply evaporative, heat and salt fluxes in \n"//& - "the sponge region. This will avoid a large increase \n"//& - "in sea level. This option is needed for some of the \n"//& - "ISOMIP+ experiments (Ocean3 and Ocean4). \n"//& - "IMPORTANT: it is not currently possible to do \n"//& + "If true, apply evaporative, heat and salt fluxes in "//& + "the sponge region. This will avoid a large increase "//& + "in sea level. This option is needed for some of the "//& + "ISOMIP+ experiments (Ocean3 and Ocean4). "//& + "IMPORTANT: it is not currently possible to do "//& "prefect restarts using this flag.", default=.false.) call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", & @@ -1217,8 +1217,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl default=-1.9, do_not_log=.true.) call get_param(param_file, mdl, "SHELF_3EQ_GAMMA", CS%const_gamma, & - "If true, user specifies a constant nondimensional heat-transfer coefficient \n"//& - "(GAMMA_T_3EQ), from which the salt-transfer coefficient is then computed \n"//& + "If true, user specifies a constant nondimensional heat-transfer coefficient "//& + "(GAMMA_T_3EQ), from which the salt-transfer coefficient is then computed "//& " as GAMMA_T_3EQ/35. This is used with SHELF_THREE_EQN.", default=.false.) if (CS%const_gamma) call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_T", CS%Gamma_T_3EQ, & "Nondimensional heat-transfer coefficient.",default=2.2E-2, & @@ -1230,19 +1230,19 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (CS%threeeq) & call get_param(param_file, mdl, "SHELF_S_ROOT", CS%find_salt_root, & - "If SHELF_S_ROOT = True, salinity at the ice/ocean interface (Sbdry) \n "//& - "is computed from a quadratic equation. Otherwise, the previous \n"//& + "If SHELF_S_ROOT = True, salinity at the ice/ocean interface (Sbdry) "//& + "is computed from a quadratic equation. Otherwise, the previous "//& "interactive method to estimate Sbdry is used.", default=.false.) if (CS%find_salt_root) then ! read liquidus coeffs. call get_param(param_file, mdl, "TFREEZE_S0_P0",CS%lambda1, & - "this is the freezing potential temperature at \n"//& + "this is the freezing potential temperature at "//& "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DS",CS%lambda1, & - "this is the derivative of the freezing potential \n"//& + "this is the derivative of the freezing potential "//& "temperature with salinity.", & units="degC psu-1", default=-0.054, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DP",CS%lambda3, & - "this is the derivative of the freezing potential \n"//& + "this is the derivative of the freezing potential "//& "temperature with pressure.", & units="degC Pa-1", default=0.0, do_not_log=.true.) @@ -1250,7 +1250,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (.not.CS%threeeq) & call get_param(param_file, mdl, "SHELF_2EQ_GAMMA_T", CS%gamma_t, & - "If SHELF_THREE_EQN is false, this the fixed turbulent \n"//& + "If SHELF_THREE_EQN is false, this the fixed turbulent "//& "exchange velocity at the ice-ocean interface.", & units="m s-1", fail_if_missing=.true.) @@ -1261,9 +1261,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The heat capacity of sea water.", units="J kg-1 K-1", & fail_if_missing=.true.) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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) !### MAKE THIS A SEPARATE PARAMETER. call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & @@ -1271,13 +1271,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl default=2.10e3) call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & - "Non-dimensional factor applied to shelf thermodynamic \n"//& + "Non-dimensional factor applied to shelf thermodynamic "//& "fluxes.", units="none", default=1.0) call get_param(param_file, mdl, "KV_ICE", CS%kv_ice, & "The viscosity of the ice.", units="m2 s-1", default=1.0e10) call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & - "The molecular kinimatic viscosity of sea water at the \n"//& + "The molecular kinimatic viscosity of sea water at the "//& "freezing temperature.", units="m2 s-1", default=1.95e-6) call get_param(param_file, mdl, "ICE_SHELF_SALINITY", CS%Salin_ice, & "The salinity of the ice inside the ice shelf.", units="psu", & @@ -1286,17 +1286,17 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The temperature at the center of the ice shelf.", & units = "degC", default=-15.0) call get_param(param_file, mdl, "KD_SALT_MOLECULAR", CS%kd_molec_salt, & - "The molecular diffusivity of salt in sea water at the \n"//& + "The molecular diffusivity of salt in sea water at the "//& "freezing point.", units="m2 s-1", default=8.02e-10) call get_param(param_file, mdl, "KD_TEMP_MOLECULAR", CS%kd_molec_temp, & - "The molecular diffusivity of heat in sea water at the \n"//& + "The molecular diffusivity of heat in sea water at the "//& "freezing point.", units="m2 s-1", default=1.41e-7) call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & "avg ocean density used in floatation cond", & units="kg m-3", default=1035.) call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & - "The time step for changing forcing, coupling with other \n"//& - "components, or potentially writing certain diagnostics. \n"//& + "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=0.0) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", CS%col_thick_melt_threshold, & @@ -1304,14 +1304,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl default=0.0) call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & - "If true, read a file (given by TIDEAMP_FILE) containing \n"//& + "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) call safe_alloc_ptr(CS%utide,isd,ied,jsd,jed) ; CS%utide(:,:) = 0.0 if (read_TIDEAMP) then call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & - "The path to the file containing the spatially varying \n"//& + "The path to the file containing the spatially varying "//& "tidal amplitudes.", & default="tideamp.nc") call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -1353,15 +1353,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The minimum value of ustar under ice sheves.", & units="m s-1", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "CDRAG_SHELF", cdrag, & - "CDRAG is the drag coefficient relating the magnitude of \n"//& + "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the surface stress.", units="nondim", & default=0.003) CS%cdrag = cdrag if (CS%ustar_bg <= 0.0) then call get_param(param_file, mdl, "DRAG_BG_VEL_SHELF", drag_bg_vel, & - "DRAG_BG_VEL is either the assumed bottom velocity (with \n"//& - "LINEAR_DRAG) or an unresolved velocity that is \n"//& - "combined with the resolved velocity to estimate the \n"//& + "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.", units="m s-1", default=0.0, scale=US%m_to_Z) if (CS%cdrag*drag_bg_vel > 0.0) CS%ustar_bg = sqrt(CS%cdrag)*drag_bg_vel endif @@ -1394,8 +1394,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call rescale_dyn_horgrid_bathymetry(dG, US%Z_to_m) ! Set up the Coriolis parameter, G%f, usually analytically. - call MOM_initialize_rotation(dG%CoriolisBu, dG, param_file) - ! This copies grid elements, inglucy bathyT and CoriolisBu from dG to CS%grid. + call MOM_initialize_rotation(dG%CoriolisBu, dG, param_file, US) + ! This copies grid elements, including bathyT and CoriolisBu from dG to CS%grid. call copy_dyngrid_to_MOM_grid(dG, CS%grid) call destroy_dyn_horgrid(dG) @@ -1536,7 +1536,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "If true, save the ice shelf initial conditions.", & default=.false.) if (save_IC) call get_param(param_file, mdl, "SHELF_IC_OUTPUT_FILE", IC_file,& - "The name-root of the output file for the ice shelf \n"//& + "The name-root of the output file for the ice shelf "//& "initial conditions.", default="MOM_Shelf_IC") if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & @@ -1606,7 +1606,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) new_sim_2 = .true. ; if (present(new_sim)) new_sim_2 = new_sim call get_param(param_file, mdl, "ICE_SHELF_CONFIG", config, & - "A string that specifies how the ice shelf is \n"//& + "A string that specifies how the ice shelf is "//& "initialized. Valid options include:\n"//& " \tfile\t Read from a file.\n"//& " \tzero\t Set shelf mass to 0 everywhere.\n"//& @@ -1622,8 +1622,8 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) inputdir = slasher(inputdir) call get_param(param_file, mdl, "SHELF_FILE", shelf_file, & - "If DYNAMIC_SHELF_MASS = True, OVERRIDE_SHELF_MOVEMENT = True \n"//& - "and ICE_SHELF_MASS_FROM_FILE = True, this is the file from \n"//& + "If DYNAMIC_SHELF_MASS = True, OVERRIDE_SHELF_MOVEMENT = True "//& + "and ICE_SHELF_MASS_FROM_FILE = True, this is the file from "//& "which to read the shelf mass and area.", & default="shelf_mass.nc") call get_param(param_file, mdl, "SHELF_MASS_VAR", shelf_mass_var, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index b53021bbb2..b1c970871b 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -225,7 +225,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) default=.false., do_not_log=.true.) if (shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & - "If true, user provided code specifies the ice-shelf \n"//& + "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) active_shelf_dynamics = .not.override_shelf_movement endif @@ -312,29 +312,29 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ override_shelf_movement = .false. ; active_shelf_dynamics = .false. if (shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & - "If true, user provided code specifies the ice-shelf \n"//& + "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) active_shelf_dynamics = .not.override_shelf_movement call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & - "If true, regularize the floatation condition at the \n"//& + "If true, regularize the floatation condition at the "//& "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", CS%n_sub_regularize, & - "The number of sub-partitions of each cell over which to \n"//& - "integrate for the interpolated grounding line. Each cell \n"//& - "is divided into NxN equally-sized rectangles, over which the \n"//& + "The number of sub-partitions of each cell over which to "//& + "integrate for the interpolated grounding line. Each cell "//& + "is divided into NxN equally-sized rectangles, over which the "//& "basal contribution is integrated by iterative quadrature.", & default=0) call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & - "If true, let the floatation condition be determined by \n"//& - "ocean column thickness. This means that update_OD_ffrac \n"//& + "If true, let the floatation condition be determined by "//& + "ocean column thickness. This means that update_OD_ffrac "//& "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & - "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). \n"// & + "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). "//& "This is only used with an ice-only model.", default=0.25) endif call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & @@ -372,14 +372,14 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & "max iteratiions in CG solver", default=2000) call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & - "min ocean thickness to consider ice *floating*; \n"// & + "min ocean thickness to consider ice *floating*; "//& "will only be important with use of tides", & units="m", default=1.e-3, scale=US%m_to_Z) call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & - "Choose whether nonlin error in vel solve is based on nonlinear \n"// & + "Choose whether nonlin error in vel solve is based on nonlinear "//& "residual (1) or relative change since last iteration (2)", default=1) call get_param(param_file, mdl, "SHELF_DYN_REPRODUCING_SUMS", CS%use_reproducing_sums, & - "If true, use the reproducing extended-fixed-point sums in \n"//& + "If true, use the reproducing extended-fixed-point sums in "//& "the ice shelf dynamics solvers.", default=.true.) call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 945b634e91..bc00ac61a9 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -42,7 +42,7 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, PF) character(len=200) :: config call get_param(PF, mdl, "ICE_PROFILE_CONFIG", config, & - "This specifies how the initial ice profile is specified. \n"//& + "This specifies how the initial ice profile is specified. "//& "Valid values are: CHANNEL, FILE, and USER.", & fail_if_missing=.true.) @@ -180,9 +180,9 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, call get_param(PF, mdl, "SHELF_EDGE_POS_0", edge_pos, & units="axis_units", default=0.0) ! call get_param(param_file, mdl, "RHO_0", Rho_ocean, & -! "The mean ocean density used with BOUSSINESQ true to \n"//& -! "calculate accelerations and the mass for conservation \n"//& -! "properties, or with BOUSSINSEQ false to convert some \n"//& +! "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%Z_to_m) @@ -272,11 +272,11 @@ end subroutine initialize_ice_thickness_channel ! logical flux_bdry ! call get_param(PF, mdl, "ICE_BOUNDARY_CONFIG", config, & -! "This specifies how the ice domain boundary is specified. \n"//& +! "This specifies how the ice domain boundary is specified. "//& ! "valid values include CHANNEL, FILE and USER.", & ! fail_if_missing=.true.) ! call get_param(PF, mdl, "ICE_BOUNDARY_FLUX_CONDITION", flux_bdry, & -! "This specifies whether mass input is a dirichlet or \n"//& +! "This specifies whether mass input is a dirichlet or "//& ! "flux condition", default=.true.) ! select case ( trim(config) ) diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index d4e83561a7..5505154d23 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -185,8 +185,7 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) character(len=40) :: mdl = "MOM_marine_ice" ! This module's name. if (associated(CS)) then - call MOM_error(WARNING, "marine_ice_init called with an "// & - "associated control structure.") + call MOM_error(WARNING, "marine_ice_init called with an associated control structure.") return else ; allocate(CS) ; endif @@ -200,8 +199,8 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) 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, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & - "Fraction of grid cell which iceberg must occupy, so that fluxes \n"//& - "below berg are set to zero. Not applied for negative \n"//& + "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) end subroutine marine_ice_init diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 2829f712e0..ec2787bae3 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -77,9 +77,9 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, if (CS%first_call) call write_user_log(param_file) CS%first_call = .false. call get_param(param_file, mdl, "RHO_0", CS%Rho_ocean, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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%Z_to_m) call get_param(param_file, mdl, "SHELF_MAX_DRAFT", CS%max_draft, & diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 8899627cc7..d497a7828e 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -275,7 +275,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & "The reduced gravity at the free surface.", units="m s-2", & default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) call get_param(param_file, mdl, "COORD_FILE", coord_file, & - "The file from which the coordinate temperatures and \n"//& + "The file from which the coordinate temperatures and "//& "salinities are read.", fail_if_missing=.true.) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -330,25 +330,25 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & call get_param(param_file, mdl, "T_REF", T_Ref, & "The default initial temperatures.", units="degC", default=10.0) call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_Light, & - "The initial temperature of the lightest layer when \n"//& + "The initial temperature of the lightest layer when "//& "COORD_CONFIG is set to ts_range.", units="degC", default=T_Ref) call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_Dense, & - "The initial temperature of the densest layer when \n"//& + "The initial temperature of the densest layer when "//& "COORD_CONFIG is set to ts_range.", units="degC", default=T_Ref) call get_param(param_file, mdl, "S_REF", S_Ref, & "The default initial salinities.", units="PSU", default=35.0) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_Light, & - "The initial lightest salinities when COORD_CONFIG \n"//& + "The initial lightest salinities when COORD_CONFIG "//& "is set to ts_range.", default = S_Ref, units="PSU") call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_Dense, & - "The initial densest salinities when COORD_CONFIG \n"//& + "The initial densest salinities when COORD_CONFIG "//& "is set to ts_range.", default = S_Ref, units="PSU") call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & - "The ratio of density space resolution in the densest \n"//& - "part of the range to that in the lightest part of the \n"//& - "range when COORD_CONFIG is set to ts_range. Values \n"//& + "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.",& default=1.0, units="nondim") @@ -408,7 +408,7 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) "The file from which the coordinate densities are read.", & fail_if_missing=.true.) call get_param(param_file, mdl, "COORD_VAR", coord_var, & - "The variable in COORD_FILE that is to be used for the \n"//& + "The variable in COORD_FILE that is to be used for the "//& "coordinate densities.", default="Layer") filename = trim(inputdir)//trim(coord_file) call log_param(param_file, mdl, "INPUTDIR/COORD_FILE", filename) @@ -449,11 +449,11 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & - "The reference potential density used for the surface \n"// & - "interface.", units="kg m-3", default=GV%Rho0) + "The reference potential density used for the surface interface.", & + units="kg m-3", default=GV%Rho0) call get_param(param_file, mdl, "DENSITY_RANGE", Rlay_range, & - "The range of reference potential densities across \n"// & - "all interfaces.", units="kg m-3", default=2.0) + "The range of reference potential densities across all interfaces.", & + units="kg m-3", default=2.0) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index c2f188bc6f..71d9c4f90b 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -134,7 +134,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) ! This call sets the topography at velocity points. if (G%bathymetry_at_vel) then call get_param(PF, mdl, "VELOCITY_DEPTH_CONFIG", config, & - "A string that determines how the topography is set at \n"//& + "A string that determines how the topography is set at "//& "velocity points. This may be 'min' or 'max'.", & default="max") select case ( trim(config) ) @@ -147,13 +147,13 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) ! Calculate the value of the Coriolis parameter at the latitude ! ! of the q grid points [s-1]. - call MOM_initialize_rotation(G%CoriolisBu, G, PF) + call MOM_initialize_rotation(G%CoriolisBu, G, PF, US=US) ! Calculate the components of grad f (beta) - call MOM_calculate_grad_Coriolis(G%dF_dx, G%dF_dy, G) + call MOM_calculate_grad_Coriolis(G%dF_dx, G%dF_dy, G, US=US) if (debug) then - call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI) - call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI) - call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI) + call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI, scale=US%s_to_T) + call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI, scale=US%s_to_T) + call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI, scale=US%s_to_T) endif call initialize_grid_rotation_angle(G, PF) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 3da13a3063..305087dc44 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -72,7 +72,7 @@ subroutine set_grid_metrics(G, param_file, US) call callTree_enter("set_grid_metrics(), MOM_grid_initialize.F90") call log_version(param_file, "MOM_grid_init", version, "") call get_param(param_file, "MOM_grid_init", "GRID_CONFIG", config, & - "A character string that determines the method for \n"//& + "A character string that determines the method for "//& "defining the horizontal grid. Current options are: \n"//& " \t mosaic - read the grid from a mosaic (supergrid) \n"//& " \t file set by GRID_FILE.\n"//& @@ -202,7 +202,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) "Name of the file from which to read horizontal grid data.", & fail_if_missing=.true.) call get_param(param_file, mdl, "USE_TRIPOLAR_GEOLONB_BUG", lon_bug, & - "If true, use older code that incorrectly sets the longitude \n"//& + "If true, use older code that incorrectly sets the longitude "//& "in some points along the tripolar fold to be off by 360 degrees.", & default=.true.) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -443,14 +443,14 @@ subroutine set_grid_metrics_cartesian(G, param_file) " \t degrees - degrees of latitude and longitude \n"//& " \t m - meters \n \t k - kilometers", default="degrees") call get_param(param_file, mdl, "SOUTHLAT", G%south_lat, & - "The southern latitude of the domain or the equivalent \n"//& + "The southern latitude of the domain or the equivalent "//& "starting value for the y-axis.", units=units_temp, & fail_if_missing=.true.) call get_param(param_file, mdl, "LENLAT", G%len_lat, & "The latitudinal or y-direction length of the domain.", & units=units_temp, fail_if_missing=.true.) call get_param(param_file, mdl, "WESTLON", G%west_lon, & - "The western longitude of the domain or the equivalent \n"//& + "The western longitude of the domain or the equivalent "//& "starting value for the x-axis.", units=units_temp, & default=0.0) call get_param(param_file, mdl, "LENLON", G%len_lon, & @@ -746,24 +746,24 @@ subroutine set_grid_metrics_mercator(G, param_file) G%west_lon = GP%west_lon ; G%len_lon = GP%len_lon G%Rad_Earth = GP%Rad_Earth call get_param(param_file, mdl, "ISOTROPIC", GP%isotropic, & - "If true, an isotropic grid on a sphere (also known as \n"//& - "a Mercator grid) is used. With an isotropic grid, the \n"//& - "meridional extent of the domain (LENLAT), the zonal \n"//& - "extent (LENLON), and the number of grid points in each \n"//& - "direction are _not_ independent. In MOM the meridional \n"//& - "extent is determined to fit the zonal extent and the \n"//& + "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.", & default=.false.) call get_param(param_file, mdl, "EQUATOR_REFERENCE", GP%equator_reference, & - "If true, the grid is defined to have the equator at the \n"//& + "If true, the grid is defined to have the equator at the "//& "nearest q- or h- grid point to (-LOWLAT*NJGLOBAL/LENLAT).", & default=.true.) call get_param(param_file, mdl, "LAT_ENHANCE_FACTOR", GP%Lat_enhance_factor, & - "The amount by which the meridional resolution is \n"//& + "The amount by which the meridional resolution is "//& "enhanced within LAT_EQ_ENHANCE of the equator.", & units="nondim", default=1.0) call get_param(param_file, mdl, "LAT_EQ_ENHANCE", GP%Lat_eq_enhance, & - "The latitude range to the north and south of the equator \n"//& + "The latitude range to the north and south of the equator "//& "over which the resolution is enhanced.", units="degrees", & default=0.0) @@ -1236,13 +1236,13 @@ subroutine initialize_masks(G, PF, US) call callTree_enter("initialize_masks(), MOM_grid_initialize.F90") m_to_Z_scale = 1.0 ; if (present(US)) m_to_Z_scale = US%m_to_Z call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & - "If MASKING_DEPTH is unspecified, then anything shallower than\n"//& - "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out.\n"//& - "If MASKING_DEPTH is specified, then all depths shallower than\n"//& + "If MASKING_DEPTH is unspecified, then anything shallower than "//& + "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out. "//& + "If MASKING_DEPTH is specified, then all depths shallower than "//& "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & units="m", default=0.0, scale=m_to_Z_scale) call get_param(PF, mdl, "MASKING_DEPTH", mask_depth, & - "The depth below which to mask points as land points, for which all\n"//& + "The depth below which to mask points as land points, for which all "//& "fluxes are zeroed out. MASKING_DEPTH is ignored if negative.", & units="m", default=-9999.0, scale=m_to_Z_scale) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 7613eae6b0..42e99f2ef6 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -56,7 +56,7 @@ end subroutine MOM_shared_init_init !> MOM_initialize_rotation makes the appropriate call to set up the Coriolis parameter. subroutine MOM_initialize_rotation(f, G, PF, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(out) :: f !< The Coriolis parameter [s-1] + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(out) :: f !< The Coriolis parameter [T-1 ~> s-1] type(param_file_type), intent(in) :: PF !< Parameter file structure type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type @@ -72,13 +72,13 @@ subroutine MOM_initialize_rotation(f, G, PF, US) "This specifies how the Coriolis parameter is specified: \n"//& " \t 2omegasinlat - Use twice the planetary rotation rate \n"//& " \t\t times the sine of latitude.\n"//& - " \t betaplane - Use a beta-plane or f-plane. \n"//& + " \t betaplane - Use a beta-plane or f-plane.\n"//& " \t USER - call a user modified routine.", & default="2omegasinlat") select case (trim(config)) - case ("2omegasinlat"); call set_rotation_planetary(f, G, PF) - case ("beta"); call set_rotation_beta_plane(f, G, PF) - case ("betaplane"); call set_rotation_beta_plane(f, G, PF) + case ("2omegasinlat"); call set_rotation_planetary(f, G, PF, US) + case ("beta"); call set_rotation_beta_plane(f, G, PF, US) + case ("betaplane"); call set_rotation_beta_plane(f, G, PF, US) !case ("nonrotating") ! Note from AJA: Missing case? case default ; call MOM_error(FATAL,"MOM_initialize: "// & "Unrecognized rotation setup "//trim(config)) @@ -90,9 +90,9 @@ end subroutine MOM_initialize_rotation subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: dF_dx !< x-component of grad f + intent(out) :: dF_dx !< x-component of grad f [T-1 m-1 ~> s-1 m-1] real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: dF_dy !< y-component of grad f + intent(out) :: dF_dy !< y-component of grad f [T-1 m-1 ~> s-1 m-1] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables integer :: i,j @@ -349,7 +349,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth ! call get_param(param_file, mdl, "RAD_EARTH", Rad_Earth, & ! "The radius of the Earth.", units="m", default=6.378e6) call get_param(param_file, mdl, "TOPOG_SLOPE_SCALE", expdecay, & - "The exponential decay scale used in defining some of \n"//& + "The exponential decay scale used in defining some of "//& "the named topographies.", units="m", default=400000.0) endif @@ -426,9 +426,9 @@ subroutine limit_topography(D, G, param_file, max_depth, US) m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "If MASKING_DEPTH is unspecified, then anything shallower than\n"//& - "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out.\n"//& - "If MASKING_DEPTH is specified, then all depths shallower than\n"//& + "If MASKING_DEPTH is unspecified, then anything shallower than "//& + "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out. "//& + "If MASKING_DEPTH is specified, then all depths shallower than "//& "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & units="m", default=0.0, scale=m_to_Z) call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, & @@ -459,20 +459,24 @@ end subroutine limit_topography subroutine set_rotation_planetary(f, G, param_file, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(out) :: f !< Coriolis parameter (vertical component) in s^-1 + intent(out) :: f !< Coriolis parameter (vertical component) [T-1 ~> s-1] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine sets up the Coriolis parameter for a sphere character(len=30) :: mdl = "set_rotation_planetary" ! This subroutine's name. integer :: I, J - real :: PI, omega + real :: PI + real :: omega ! The planetary rotation rate [T-1 ~> s-1] + real :: T_to_s ! A time unit conversion factor call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + T_to_s = 1.0 ; if (present(US)) T_to_s = US%T_to_s + call get_param(param_file, "set_rotation_planetary", "OMEGA", omega, & "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5) + default=7.2921e-5, scale=T_to_s) PI = 4.0*atan(1.0) do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB @@ -488,24 +492,30 @@ end subroutine set_rotation_planetary subroutine set_rotation_beta_plane(f, G, param_file, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(out) :: f !< Coriolis parameter (vertical component) in s^-1 + intent(out) :: f !< Coriolis parameter (vertical component) [T-1 ~> s-1] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine sets up the Coriolis parameter for a beta-plane integer :: I, J - real :: f_0, beta, y_scl, Rad_Earth, PI + real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] + real :: beta ! The meridional gradient of the Coriolis parameter [T-1 m-1 ~> s-1 m-1] + real :: y_scl, Rad_Earth + real :: T_to_s ! A time unit conversion factor + real :: PI character(len=40) :: mdl = "set_rotation_beta_plane" ! This subroutine's name. character(len=200) :: axis_units call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + T_to_s = 1.0 ; if (present(US)) T_to_s = US%T_to_s + call get_param(param_file, mdl, "F_0", f_0, & - "The reference value of the Coriolis parameter with the \n"//& - "betaplane option.", units="s-1", default=0.0) + "The reference value of the Coriolis parameter with the "//& + "betaplane option.", units="s-1", default=0.0, scale=T_to_s) call get_param(param_file, mdl, "BETA", beta, & - "The northward gradient of the Coriolis parameter with \n"//& - "the betaplane option.", units="m-1 s-1", default=0.0) + "The northward gradient of the Coriolis parameter with "//& + "the betaplane option.", units="m-1 s-1", default=0.0, scale=T_to_s) call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") PI = 4.0*atan(1.0) @@ -544,8 +554,8 @@ subroutine initialize_grid_rotation_angle(G, PF) integer :: i, j, m, n call get_param(PF, mdl, "GRID_ROTATION_ANGLE_BUGS", use_bugs, & - "If true, use an older algorithm to calculate the sine and \n"//& - "cosines needed rotate between grid-oriented directions and \n"//& + "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.", & default=.True.) @@ -832,7 +842,7 @@ subroutine reset_face_lengths_list(G, param_file, US) filename = trim(inputdir)//trim(chan_file) call log_param(param_file, mdl, "INPUTDIR/CHANNEL_LIST_FILE", filename) call get_param(param_file, mdl, "CHANNEL_LIST_360_LON_CHECK", check_360, & - "If true, the channel configuration list works for any \n"//& + "If true, the channel configuration list works for any "//& "longitudes in the range of -360 to 360.", default=.true.) if (is_root_pe()) then @@ -1159,6 +1169,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) type(vardesc) :: vars(nFlds) type(fieldtype) :: fields(nFlds) real :: Z_to_m_scale ! A unit conversion factor from Z to m. + real :: s_to_T_scale ! A unit conversion factor from T-1 to s-1. integer :: unit integer :: file_threading integer :: nFlds_used @@ -1176,6 +1187,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB Z_to_m_scale = 1.0 ; if (present(US)) Z_to_m_scale = US%Z_to_m + s_to_T_scale = 1.0 ; if (present(US)) s_to_T_scale = US%s_to_T ! vardesc is a structure defined in MOM_io.F90. The elements of ! this structure, in order, are: @@ -1229,7 +1241,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) out_q(:,:) = 0.0 call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", multiple_files, & - "If true, each processor writes its own restart file, \n"//& + "If true, each processor writes its own restart file, "//& "otherwise a single restart file is generated", & default=.false.) file_threading = SINGLE_FILE @@ -1247,7 +1259,8 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) do j=js,je ; do i=is,ie ; out_h(i,j) = Z_to_m_scale*G%bathyT(i,j) ; enddo ; enddo call write_field(unit, fields(5), G%Domain%mpp_domain, out_h) - call write_field(unit, fields(6), G%Domain%mpp_domain, G%CoriolisBu) + do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(i,J) = s_to_T_scale*G%CoriolisBu(I,J) ; enddo ; enddo + call write_field(unit, fields(6), G%Domain%mpp_domain, out_q) ! I think that all of these copies are holdovers from a much earlier ! ancestor code in which many of the metrics were macros that could have diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4c7b720f67..76f4cbc685 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -229,9 +229,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! is just to make sure that all valid parameters are read to enable the ! detection of unused parameters. call get_param(PF, mdl, "INIT_LAYERS_FROM_Z_FILE", from_Z_file, & - "If true, intialize the layer thicknesses, temperatures, \n"//& - "and salnities from a Z-space file on a latitude- \n"//& - "longitude grid.", default=.false., do_not_log=just_read) + "If true, initialize the layer thicknesses, temperatures, "//& + "and salinities from a Z-space file on a latitude-longitude "//& + "grid.", default=.false., do_not_log=just_read) if (from_Z_file) then ! Initialize thickness and T/S from z-coordinate data in a file. @@ -243,7 +243,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & else ! Initialize thickness, h. call get_param(PF, mdl, "THICKNESS_CONFIG", config, & - "A string that determines how the initial layer \n"//& + "A string that determines how the initial layer "//& "thicknesses are specified for a new run: \n"//& " \t file - read interface heights from the file specified \n"//& " \t thickness_file - read thicknesses from the file specified \n"//& @@ -325,7 +325,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! Initialize temperature and salinity (T and S). if ( use_temperature ) then call get_param(PF, mdl, "TS_CONFIG", config, & - "A string that determines how the initial tempertures \n"//& + "A string that determines how the initial tempertures "//& "and salinities are specified for a new run: \n"//& " \t file - read velocities from the file specified \n"//& " \t\t by (TS_FILE). \n"//& @@ -392,7 +392,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! Initialize velocity components, u and v call get_param(PF, mdl, "VELOCITY_CONFIG", config, & - "A string that determines how the initial velocities \n"//& + "A string that determines how the initial velocities "//& "are specified for a new run: \n"//& " \t file - read velocities from the file specified \n"//& " \t\t by (VELOCITY_FILE). \n"//& @@ -415,7 +415,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, & just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, & - G, GV, PF, just_read_params=just_read) + G, GV, US, PF, just_read_params=just_read) case ("soliton"); call soliton_initialize_velocity(u, v, h, G) case ("USER"); call user_initialize_velocity(u, v, G, PF, & just_read_params=just_read) @@ -431,9 +431,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! Optionally convert the thicknesses from m to kg m-2. This is particularly ! useful in a non-Boussinesq model. call get_param(PF, mdl, "CONVERT_THICKNESS_UNITS", convert, & - "If true, convert the thickness initial conditions from \n"//& - "units of m to kg m-2 or vice versa, depending on whether \n"//& - "BOUSSINESQ is defined. This does not apply if a restart \n"//& + "If true, convert the thickness initial conditions from "//& + "units of m to kg m-2 or vice versa, depending on whether "//& + "BOUSSINESQ is defined. This does not apply if a restart "//& "file is read.", default=.not.GV%Boussinesq, do_not_log=just_read) if (new_sim .and. convert .and. .not.GV%Boussinesq) & @@ -442,12 +442,12 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! Remove the mass that would be displaced by an ice shelf or inverse barometer. call get_param(PF, mdl, "DEPRESS_INITIAL_SURFACE", depress_sfc, & - "If true, depress the initial surface to avoid huge \n"//& + "If true, depress the initial surface to avoid huge "//& "tsunamis when a large surface pressure is applied.", & default=.false., do_not_log=just_read) call get_param(PF, mdl, "TRIM_IC_FOR_P_SURF", trim_ic_for_p_surf, & - "If true, cuts way the top of the column for initial conditions\n"//& - "at the depth where the hydrostatic presure matches the imposed\n"//& + "If true, cuts way the top of the column for initial conditions "//& + "at the depth where the hydrostatic pressure matches the imposed "//& "surface pressure which is read from file.", default=.false., & do_not_log=just_read) if (depress_sfc .and. trim_ic_for_p_surf) call MOM_error(FATAL, "MOM_initialize_state: "//& @@ -461,13 +461,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! iterations here so the initial grid is consistent with the coordinate if (useALE) then call get_param(PF, mdl, "REGRID_ACCELERATE_INIT", regrid_accelerate, & - "If true, runs REGRID_ACCELERATE_ITERATIONS iterations of the regridding\n"//& - "algorithm to push the initial grid to be consistent with the initial\n"//& + "If true, runs REGRID_ACCELERATE_ITERATIONS iterations of the regridding "//& + "algorithm to push the initial grid to be consistent with the initial "//& "condition. Useful only for state-based and iterative coordinates.", & default=.false., do_not_log=just_read) if (regrid_accelerate) then call get_param(PF, mdl, "REGRID_ACCELERATE_ITERATIONS", regrid_iterations, & - "The number of regridding iterations to perform to generate\n"//& + "The number of regridding iterations to perform to generate "//& "an initial grid that is consistent with the initial conditions.", & default=1, do_not_log=just_read) @@ -513,8 +513,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & endif call get_param(PF, mdl, "SPONGE", use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified via SPONGE_CONFIG.", default=.false.) if ( use_sponge ) then call get_param(PF, mdl, "SPONGE_CONFIG", config, & @@ -554,8 +554,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! This controls user code for setting open boundary data if (associated(OBC)) then call get_param(PF, mdl, "OBC_USER_CONFIG", config, & - "A string that sets how the user code is invoked to set open\n"//& - " boundary data: \n"//& + "A string that sets how the user code is invoked to set open boundary data: \n"//& " DOME - specified inflow on northern boundary\n"//& " dyed_channel - supercritical with dye on the inflow boundary\n"//& " dyed_obcs - circle_obcs with dyes on the open boundaries\n"//& @@ -655,8 +654,8 @@ subroutine initialize_thickness_from_file(h, G, GV, US, param_file, file_has_thi call MOM_read_data(filename, "h", h(:,:,:), G%Domain, scale=GV%m_to_H) else call get_param(param_file, mdl, "ADJUST_THICKNESS", correct_thickness, & - "If true, all mass below the bottom removed if the \n"//& - "topography is shallower than the thickness input file \n"//& + "If true, all mass below the bottom removed if the "//& + "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -854,10 +853,10 @@ subroutine initialize_thickness_list(h, G, GV, US, param_file, just_read_params) just_read = .false. ; if (present(just_read_params)) just_read = just_read_params call get_param(param_file, mdl, "INTERFACE_IC_FILE", eta_file, & - "The file from which horizontal mean initial conditions \n"//& + "The file from which horizontal mean initial conditions "//& "for interface depths can be read.", fail_if_missing=.true.) call get_param(param_file, mdl, "INTERFACE_IC_VAR", eta_var, & - "The variable name for horizontal mean initial conditions \n"//& + "The variable name for horizontal mean initial conditions "//& "for interface depths relative to mean sea level.", & default="eta") @@ -1029,7 +1028,7 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read_params) call log_param(param_file, mdl, "INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_SCALE", scale_factor, & - "A scaling factor to convert SURFACE_HEIGHT_IC_VAR into \n"//& + "A scaling factor to convert SURFACE_HEIGHT_IC_VAR into "//& "units of m", units="variable", default=1.0, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -1108,7 +1107,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) if (.not.just_read) call log_param(PF, mdl, "!INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) call get_param(PF, mdl, "SURFACE_PRESSURE_SCALE", scale_factor, & - "A scaling factor to convert SURFACE_PRESSURE_VAR from\n"//& + "A scaling factor to convert SURFACE_PRESSURE_VAR from "//& "file SURFACE_PRESSURE_FILE into a surface pressure.", & units="file dependent", default=1., do_not_log=just_read) call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & @@ -1371,7 +1370,7 @@ subroutine initialize_velocity_circular(u, v, G, param_file, just_read_params) just_read = .false. ; if (present(just_read_params)) just_read = just_read_params call get_param(param_file, mdl, "CIRCULAR_MAX_U", circular_max_u, & - "The amplitude of zonal flow from which to scale the\n"// & + "The amplitude of zonal flow from which to scale the "// & "circular stream function [m s-1].", & units="m s-1", default=0., do_not_log=just_read) @@ -1487,7 +1486,7 @@ subroutine initialize_temp_salt_from_profile(T, S, G, param_file, just_read_para if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") call get_param(param_file, mdl, "TS_FILE", ts_file, & - "The file with the reference profiles for temperature \n"//& + "The file with the reference profiles for temperature "//& "and salinity.", fail_if_missing=.not.just_read, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -1551,7 +1550,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, param_file, eqn_of_state, P_Ref "A reference salinity used in initialization.", units="PSU", & default=35.0, do_not_log=just_read) call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & - "If true, accept the prescribed temperature and fit the \n"//& + "If true, accept the prescribed temperature and fit the "//& "salinity; otherwise take salinity and fit temperature.", & default=.false., do_not_log=just_read) @@ -1724,27 +1723,27 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C "The name of the file with the state to damp toward.", & default=damping_file) call get_param(param_file, mdl, "SPONGE_PTEMP_VAR", potemp_var, & - "The name of the potential temperature variable in \n"//& + "The name of the potential temperature variable in "//& "SPONGE_STATE_FILE.", default="PTEMP") call get_param(param_file, mdl, "SPONGE_SALT_VAR", salin_var, & - "The name of the salinity variable in \n"//& + "The name of the salinity variable in "//& "SPONGE_STATE_FILE.", default="SALT") call get_param(param_file, mdl, "SPONGE_ETA_VAR", eta_var, & - "The name of the interface height variable in \n"//& + "The name of the interface height variable in "//& "SPONGE_STATE_FILE.", default="ETA") call get_param(param_file, mdl, "SPONGE_IDAMP_VAR", Idamp_var, & - "The name of the inverse damping rate variable in \n"//& + "The name of the inverse damping rate variable in "//& "SPONGE_DAMPING_FILE.", default="IDAMP") call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) call get_param(param_file, mdl, "NEW_SPONGES", new_sponges, & - "Set True if using the newer sponging code which \n"//& + "Set True if using the newer sponging code which "//& "performs on-the-fly regridding in lat-lon-time.",& "of sponge restoring data.", default=.false.) ! if (use_ALE) then ! call get_param(param_file, mdl, "SPONGE_RESTORE_ETA", restore_eta, & -! "If true, then restore the interface positions towards \n"//& +! "If true, then restore the interface positions towards "//& ! "target values (in ALE mode)", default = .false.) ! endif @@ -2024,45 +2023,45 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param call get_param(PF, mdl, "NKBL",nkbl,default=0) call get_param(PF, mdl, "TEMP_SALT_Z_INIT_FILE",filename, & - "The name of the z-space input file used to initialize \n"//& - "temperatures (T) and salinities (S). If T and S are not \n" //& - "in the same file, TEMP_Z_INIT_FILE and SALT_Z_INIT_FILE \n" //& + "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.",default="temp_salt_z.nc",do_not_log=just_read) call get_param(PF, mdl, "TEMP_Z_INIT_FILE",tfilename, & - "The name of the z-space input file used to initialize \n"//& + "The name of the z-space input file used to initialize "//& "temperatures, only.", default=trim(filename),do_not_log=just_read) call get_param(PF, mdl, "SALT_Z_INIT_FILE",sfilename, & - "The name of the z-space input file used to initialize \n"//& + "The name of the z-space input file used to initialize "//& "temperatures, only.", default=trim(filename),do_not_log=just_read) filename = trim(inputdir)//trim(filename) tfilename = trim(inputdir)//trim(tfilename) sfilename = trim(inputdir)//trim(sfilename) call get_param(PF, mdl, "Z_INIT_FILE_PTEMP_VAR", potemp_var, & - "The name of the potential temperature variable in \n"//& + "The name of the potential temperature variable in "//& "TEMP_Z_INIT_FILE.", default="ptemp",do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_FILE_SALT_VAR", salin_var, & - "The name of the salinity variable in \n"//& + "The name of the salinity variable in "//& "SALT_Z_INIT_FILE.", default="salt",do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_HOMOGENIZE", homogenize, & - "If True, then horizontally homogenize the interpolated \n"//& + "If True, then horizontally homogenize the interpolated "//& "initial conditions.", default=.false., do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_ALE_REMAPPING", useALEremapping, & - "If True, then remap straight to model coordinate from file.",& + "If True, then remap straight to model coordinate from file.", & default=.false., do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remappingScheme, & - "The remapping scheme to use if using Z_INIT_ALE_REMAPPING\n"//& + "The remapping scheme to use if using Z_INIT_ALE_REMAPPING "//& "is True.", default="PPM_IH4", do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_GENERAL", remap_general, & - "If false, only initializes to z* coordinates.\n"//& + "If false, only initializes to z* coordinates. "//& "If true, allows initialization directly to general coordinates.",& default=.false., do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_FULL_COLUMN", remap_full_column, & - "If false, only reconstructs profiles for valid data points.\n"//& - "If true, inserts vanished layers below the valid data.",& + "If false, only reconstructs profiles for valid data points. "//& + "If true, inserts vanished layers below the valid data.", & default=remap_general, do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_OLD_ALG", remap_old_alg, & - "If false, uses the preferred remapping algorithm for initialization.\n"//& - "If true, use an older, less robust algorithm for remapping.",& + "If false, uses the preferred remapping algorithm for initialization. "//& + "If true, use an older, less robust algorithm for remapping.", & default=.true., do_not_log=just_read) call get_param(PF, mdl, "ICE_SHELF", use_ice_shelf, default=.false.) if (use_ice_shelf) then @@ -2077,14 +2076,14 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param endif if (.not.useALEremapping) then call get_param(PF, mdl, "ADJUST_THICKNESS", correct_thickness, & - "If true, all mass below the bottom removed if the \n"//& - "topography is shallower than the thickness input file \n"//& + "If true, all mass below the bottom removed if the "//& + "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) call get_param(PF, mdl, "FIT_TO_TARGET_DENSITY_IC", adjust_temperature, & - "If true, all the interior layers are adjusted to \n"//& - "their target densities using mostly temperature \n"//& - "This approach can be problematic, particularly in the \n"//& + "If true, all the interior layers are adjusted to "//& + "their target densities using mostly temperature "//& + "This approach can be problematic, particularly in the "//& "high latitudes.", default=.true., do_not_log=just_read) endif if (just_read) then diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 27511e1593..08fb487bc5 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -103,14 +103,14 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") call get_param(PF, mdl, "Z_INIT_HOMOGENIZE", homog, & - "If True, then horizontally homogenize the interpolated \n"//& + "If True, then horizontally homogenize the interpolated "//& "initial conditions.", default=.false.) call get_param(PF, mdl, "Z_INIT_ALE_REMAPPING", useALE, & "If True, then remap straight to model coordinate from file.",& default=.true.) call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remapScheme, & - "The remapping scheme to use if using Z_INIT_ALE_REMAPPING\n"//& - "is True.", default="PLM") + "The remapping scheme to use if using Z_INIT_ALE_REMAPPING is True.", & + default="PLM") ! These are model grid properties, but being applied to the data grid for now. ! need to revisit this (mjh) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 1a9bf92c57..27dde7f69d 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -150,7 +150,7 @@ subroutine init_oda(Time, G, GV, CS) call unit_scaling_init(PF, CS%US) call get_param(PF, "MOM", "ASSIM_METHOD", assim_method, & - "String which determines the data assimilation method" // & + "String which determines the data assimilation method "//& "Valid methods are: \'EAKF\',\'OI\', and \'NO_ASSIM\'", default='NO_ASSIM') call get_param(PF, "MOM", "ASSIM_FREQUENCY", CS%assim_frequency, & "data assimilation frequency in hours") @@ -163,14 +163,14 @@ subroutine init_oda(Time, G, GV, CS) "If true, the domain is meridionally reentrant.", & default=.false.) call get_param(PF,"MOM", "TRIPOLAR_N", CS%tripolar_N, & - "Use tripolar connectivity at the northern edge of the \n"//& + "Use tripolar connectivity at the northern edge of the "//& "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & default=.false.) call get_param(PF,"MOM", "NIGLOBAL", CS%ni, & - "The total number of thickness grid points in the \n"//& + "The total number of thickness grid points in the "//& "x-direction in the physical domain.") call get_param(PF,"MOM", "NJGLOBAL", CS%nj, & - "The total number of thickness grid points in the \n"//& + "The total number of thickness grid points in the "//& "y-direction in the physical domain.") call get_param(PF, 'MOM', "INPUTDIR", inputdir) inputdir = slasher(inputdir) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 21e06ebcef..78427dddf8 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -44,6 +44,7 @@ module MOM_MEKE logical :: Rd_as_max_scale !< If true the length scale can not exceed the !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. + logical :: use_min_lscale !< Use simple minimum for mixing length scale. real :: cdrag !< The bottom drag coefficient for MEKE [nondim]. real :: MEKE_BGsrc !< Background energy source for MEKE [W kg-1] (= m2 s-3). real :: MEKE_dtScale !< Scale factor to accelerate time-stepping [nondim] @@ -257,7 +258,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif ! Calculates bottomFac2, barotrFac2 and LmixScale - call MEKE_lengthScales(CS, MEKE, G, US, SN_u, SN_v, MEKE%MEKE, bottomFac2, barotrFac2, LmixScale) + call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, bottomFac2, barotrFac2, LmixScale) if (CS%debug) then call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI) call hchksum(mass, 'MEKE mass',G%HI,haloshift=1) @@ -561,7 +562,8 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real :: beta, SN, bottomFac2, barotrFac2, LmixScale, Lrhines, Leady real :: I_H, KhCoeff, Kh, Ubg2, cd2, drag_rate, ldamping, src real :: EKE, EKEmin, EKEmax, resid, ResMin, ResMax, EKEerr - real :: FatH ! Coriolis parameter at h points; to compute topographic beta + real :: FatH ! Coriolis parameter at h points; to compute topographic beta [s-1] + real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [s-1 m-1] integer :: i, j, is, ie, js, je, n1, n2 real, parameter :: tolerance = 1.e-12 ! Width of EKE bracket [m2 s-2]. logical :: useSecant, debugIteration @@ -579,12 +581,36 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v SN = min( min(SN_u(I,j) , SN_u(I-1,j)) , min(SN_v(i,J), SN_v(i,J-1)) ) - FatH = 0.25*((G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) + & + FatH = 0.25*US%s_to_T*((G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) + & (G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1))) !< Coriolis parameter at h points - beta = sqrt( ( G%dF_dx(i,j) - CS%MEKE_topographic_beta*FatH/G%bathyT(i,j)* & - (G%bathyT(i+1,j) - G%bathyT(i-1,j))/2./G%dxT(i,j) )**2. & - + ( G%dF_dy(i,j) - CS%MEKE_topographic_beta*FatH/G%bathyT(i,j) & - *(G%bathyT(i,j+1) - G%bathyT(i,j-1))/2./G%dyT(i,j) )**2. ) + + ! Since zero-bathymetry cells are masked, this avoids calculations on land + if (CS%MEKE_topographic_beta == 0. .or. G%bathyT(i,j) == 0.) then + beta_topo_x = 0. ; beta_topo_y = 0. + else + !### These expressions should be recast to use a single division, but it will change answers. + !beta_topo_x = CS%MEKE_topographic_beta * FatH & + ! * 0.5 * (G%bathyT(i+1,j) - G%bathyT(i-1,j)) * G%IdxT(i,j) / G%bathyT(i,j) + !beta_topo_y = CS%MEKE_topographic_beta * FatH & + ! * 0.5 * (G%bathyT(i,j+1) - G%bathyT(i,j-1)) * G&IdxT(i,j) / G%bathyT(i,j) + !beta_topo_x = CS%MEKE_topographic_beta * FatH / G%bathyT(i,j) & + ! * (G%bathyT(i+1,j) - G%bathyT(i-1,j)) / 2. / G%dxT(i,j) + !beta_topo_y = CS%MEKE_topographic_beta * FatH / G%bathyT(i,j) & + ! * (G%bathyT(i,j+1) - G%bathyT(i,j-1)) / 2. / G%dyT(i,j) + beta_topo_x = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & + /max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & + + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & + /max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) + beta_topo_y = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & + /max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & + (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdxCu(i,J-1) & + /max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) + endif + + beta = sqrt((US%s_to_T * G%dF_dx(i,j) - beta_topo_x)**2 & + + (US%s_to_T * G%dF_dy(i,j) - beta_topo_y)**2 ) I_H = GV%Rho0 * I_mass(i,j) @@ -676,11 +702,12 @@ end subroutine MEKE_equilibrium !> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ !! functions that are ratios of either bottom or barotropic eddy energy to the !! column eddy energy, respectively. See \ref section_MEKE_equations. -subroutine MEKE_lengthScales(CS, MEKE, G, US, SN_u, SN_v, & +subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, & EKE, bottomFac2, barotrFac2, LmixScale) type(MEKE_CS), pointer :: CS !< MEKE control structure. type(MEKE_type), pointer :: MEKE !< MEKE data. type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [s-1]. @@ -690,7 +717,9 @@ subroutine MEKE_lengthScales(CS, MEKE, G, US, SN_u, SN_v, & real, dimension(SZI_(G),SZJ_(G)), intent(out) :: LmixScale !< Eddy mixing length [m]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: Lrhines, Leady - real :: beta, SN, FatH + real :: beta, SN + real :: FatH ! Coriolis parameter at h points [s-1] + real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [s-1 m-1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -699,16 +728,45 @@ subroutine MEKE_lengthScales(CS, MEKE, G, US, SN_u, SN_v, & do j=js,je ; do i=is,ie if (.not.CS%use_old_lscale) then if (CS%aEady > 0.) then - SN = 0.25*( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)) ) + SN = 0.25*( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)) ) else SN = 0. endif - FatH = 0.25*( ( G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1) ) + & - ( G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1) ) ) ! Coriolis parameter at h points - beta = sqrt( ( G%dF_dx(i,j) - CS%MEKE_topographic_beta*FatH/G%bathyT(i,j) & - *(G%bathyT(i+1,j) - G%bathyT(i-1,j)) /2./G%dxT(i,j) )**2. & - + ( G%dF_dy(i,j) - CS%MEKE_topographic_beta*FatH/G%bathyT(i,j) & - *(G%bathyT(i,j+1) - G%bathyT(i,j-1))/2./G%dyT(i,j) )**2. ) + FatH = 0.25*US%s_to_T* ( ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1) ) + & + ( G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1) ) ) ! Coriolis parameter at h points + + ! If bathyT is zero, then a division by zero FPE will be raised. In this + ! case, we apply Adcroft's rule of reciprocals and set the term to zero. + ! Since zero-bathymetry cells are masked, this should not affect values. + if (CS%MEKE_topographic_beta == 0. .or. G%bathyT(i,j) == 0.0) then + beta_topo_x = 0. ; beta_topo_y = 0. + else + !### These expressions should be recast to use a single division, but it will change answers. + !beta_topo_x = CS%MEKE_topographic_beta * FatH & + ! * 0.5 * (G%bathyT(i+1,j) - G%bathyT(i-1,j)) * G%IdxT(i,j) / G%bathyT(i,j) + !beta_topo_y = CS%MEKE_topographic_beta * FatH & + ! * 0.5 * (G%bathyT(i,j+1) - G%bathyT(i,j-1)) * G&IdxT(i,j) / G%bathyT(i,j) + !beta_topo_x = CS%MEKE_topographic_beta * FatH / G%bathyT(i,j) & + ! * (G%bathyT(i+1,j) - G%bathyT(i-1,j)) / 2. / G%dxT(i,j) + !beta_topo_y = CS%MEKE_topographic_beta * FatH / G%bathyT(i,j) & + ! * (G%bathyT(i,j+1) - G%bathyT(i,j-1)) / 2. / G%dyT(i,j) + beta_topo_x = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & + /max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & + + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & + /max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) + beta_topo_y = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & + /max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & + (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdxCu(i,J-1) & + /max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) + endif + + beta = sqrt((US%s_to_T * G%dF_dx(i,j) - beta_topo_x)**2 & + + (US%s_to_T * G%dF_dy(i,j) - beta_topo_y)**2 ) + + else + beta = 0. endif ! Returns bottomFac2, barotrFac2 and LmixScale call MEKE_lengthScales_0d(CS, G%areaT(i,j), beta, G%bathyT(i,j), & @@ -771,14 +829,24 @@ subroutine MEKE_lengthScales_0d(CS, area, beta, depth, Rd_dx, SN, EKE, Z_to_L, & else Leady = 0. endif - LmixScale = 0. - if (CS%aDeform*Ldeform > 0.) LmixScale = LmixScale + 1./(CS%aDeform*Ldeform) - if (CS%aFrict *Lfrict > 0.) LmixScale = LmixScale + 1./(CS%aFrict *Lfrict) - if (CS%aRhines*Lrhines > 0.) LmixScale = LmixScale + 1./(CS%aRhines*Lrhines) - if (CS%aEady *Leady > 0.) LmixScale = LmixScale + 1./(CS%aEady *Leady) - if (CS%aGrid *Lgrid > 0.) LmixScale = LmixScale + 1./(CS%aGrid *Lgrid) - if (CS%Lfixed > 0.) LmixScale = LmixScale + 1./CS%Lfixed - if (LmixScale > 0.) LmixScale = 1. / LmixScale + if (CS%use_min_lscale) then + LmixScale = 1.e7 + if (CS%aDeform*Ldeform > 0.) LmixScale = min(LmixScale,CS%aDeform*Ldeform) + if (CS%aFrict *Lfrict > 0.) LmixScale = min(LmixScale,CS%aFrict *Lfrict) + if (CS%aRhines*Lrhines > 0.) LmixScale = min(LmixScale,CS%aRhines*Lrhines) + if (CS%aEady *Leady > 0.) LmixScale = min(LmixScale,CS%aEady *Leady) + if (CS%aGrid *Lgrid > 0.) LmixScale = min(LmixScale,CS%aGrid *Lgrid) + if (CS%Lfixed > 0.) LmixScale = min(LmixScale,CS%Lfixed) + else + LmixScale = 0. + if (CS%aDeform*Ldeform > 0.) LmixScale = LmixScale + 1./(CS%aDeform*Ldeform) + if (CS%aFrict *Lfrict > 0.) LmixScale = LmixScale + 1./(CS%aFrict *Lfrict) + if (CS%aRhines*Lrhines > 0.) LmixScale = LmixScale + 1./(CS%aRhines*Lrhines) + if (CS%aEady *Leady > 0.) LmixScale = LmixScale + 1./(CS%aEady *Leady) + if (CS%aGrid *Lgrid > 0.) LmixScale = LmixScale + 1./(CS%aGrid *Lgrid) + if (CS%Lfixed > 0.) LmixScale = LmixScale + 1./CS%Lfixed + if (LmixScale > 0.) LmixScale = 1. / LmixScale + endif endif end subroutine MEKE_lengthScales_0d @@ -806,7 +874,7 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) ! Determine whether this module will be used call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_MEKE", MEKE_init, & - "If true, turns on the MEKE scheme which calculates\n"// & + "If true, turns on the MEKE scheme which calculates "// & "a sub-grid mesoscale eddy kinetic energy budget.", & default=.false.) if (.not. MEKE_init) return @@ -827,59 +895,59 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "MEKE_DAMPING", CS%MEKE_damping, & - "The local depth-indepented MEKE dissipation rate.", & + "The local depth-independent MEKE dissipation rate.", & units="s-1", default=0.0) call get_param(param_file, mdl, "MEKE_CD_SCALE", CS%MEKE_Cd_scale, & - "The ratio of the bottom eddy velocity to the column mean\n"//& - "eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1\n"//& + "The ratio of the bottom eddy velocity to the column mean "//& + "eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1 "//& "to account for the surface intensification of MEKE.", & units="nondim", default=0.) call get_param(param_file, mdl, "MEKE_CB", CS%MEKE_Cb, & - "A coefficient in the expression for the ratio of bottom projected\n"//& + "A coefficient in the expression for the ratio of bottom projected "//& "eddy energy and mean column energy (see Jansen et al. 2015).",& units="nondim", default=25.) call get_param(param_file, mdl, "MEKE_MIN_GAMMA2", CS%MEKE_min_gamma, & "The minimum allowed value of gamma_b^2.",& units="nondim", default=0.0001) call get_param(param_file, mdl, "MEKE_CT", CS%MEKE_Ct, & - "A coefficient in the expression for the ratio of barotropic\n"//& + "A coefficient in the expression for the ratio of barotropic "//& "eddy energy and mean column energy (see Jansen et al. 2015).",& units="nondim", default=50.) call get_param(param_file, mdl, "MEKE_GMCOEFF", CS%MEKE_GMcoeff, & - "The efficiency of the conversion of potential energy \n"//& - "into MEKE by the thickness mixing parameterization. \n"//& - "If MEKE_GMCOEFF is negative, this conversion is not \n"//& + "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.", units="nondim", default=-1.0) call get_param(param_file, mdl, "MEKE_FRCOEFF", CS%MEKE_FrCoeff, & - "The efficiency of the conversion of mean energy into \n"//& - "MEKE. If MEKE_FRCOEFF is negative, this conversion \n"//& + "The efficiency of the conversion of mean energy into "//& + "MEKE. If MEKE_FRCOEFF is negative, this conversion "//& "is not used or calculated.", units="nondim", default=-1.0) call get_param(param_file, mdl, "MEKE_BGSRC", CS%MEKE_BGsrc, & "A background energy source for MEKE.", units="W kg-1", & default=0.0) call get_param(param_file, mdl, "MEKE_KH", CS%MEKE_Kh, & - "A background lateral diffusivity of MEKE.\n"//& + "A background lateral diffusivity of MEKE. "//& "Use a negative value to not apply lateral diffusion to MEKE.", & units="m2 s-1", default=-1.0) call get_param(param_file, mdl, "MEKE_K4", CS%MEKE_K4, & - "A lateral bi-harmonic diffusivity of MEKE.\n"//& + "A lateral bi-harmonic diffusivity of MEKE. "//& "Use a negative value to not apply bi-harmonic diffusion to MEKE.", & units="m4 s-1", default=-1.0) call get_param(param_file, mdl, "MEKE_DTSCALE", CS%MEKE_dtScale, & "A scaling factor to accelerate the time evolution of MEKE.", & units="nondim", default=1.0) call get_param(param_file, mdl, "MEKE_KHCOEFF", CS%MEKE_KhCoeff, & - "A scaling factor in the expression for eddy diffusivity\n"//& - "which is otherwise proportional to the MEKE velocity-\n"//& - "scale times an eddy mixing-length. This factor\n"//& - "must be >0 for MEKE to contribute to the thickness/\n"//& + "A scaling factor in the expression for eddy diffusivity "//& + "which is otherwise proportional to the MEKE velocity- "//& + "scale times an eddy mixing-length. This factor "//& + "must be >0 for MEKE to contribute to the thickness/ "//& "and tracer diffusivity in the rest of the model.", & units="nondim", default=1.0) call get_param(param_file, mdl, "MEKE_USCALE", CS%MEKE_Uscale, & - "The background velocity that is combined with MEKE to \n"//& + "The background velocity that is combined with MEKE to "//& "calculate the bottom drag.", units="m s-1", default=0.0) call get_param(param_file, mdl, "MEKE_VISC_DRAG", CS%visc_drag, & - "If true, use the vertvisc_type to calculate the bottom \n"//& + "If true, use the vertvisc_type to calculate the bottom "//& "drag acting on MEKE.", default=.true.) call get_param(param_file, mdl, "MEKE_KHTH_FAC", MEKE%KhTh_fac, & "A factor that maps MEKE%Kh to KhTh.", units="nondim", & @@ -891,67 +959,71 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) "A factor that maps MEKE%Kh to Kh for MEKE itself.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_OLD_LSCALE", CS%use_old_lscale, & - "If true, use the old formula for length scale which is\n"//& + "If true, use the old formula for length scale which is "//& "a function of grid spacing and deformation radius.", & default=.false.) + call get_param(param_file, mdl, "MEKE_MIN_LSCALE", CS%use_min_lscale, & + "If true, use a strict minimum of provided length scales "//& + "rather than harmonic mean.", & + default=.false.) call get_param(param_file, mdl, "MEKE_RD_MAX_SCALE", CS%Rd_as_max_scale, & - "If true, the length scale used by MEKE is the minimum of\n"//& - "the deformation radius or grid-spacing. Only used if\n"//& + "If true, the length scale used by MEKE is the minimum of "//& + "the deformation radius or grid-spacing. Only used if "//& "MEKE_OLD_LSCALE=True", units="nondim", default=.false.) call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF", CS%viscosity_coeff, & - "If non-zero, is the scaling coefficient in the expression for\n"//& - "viscosity used to parameterize lateral momentum mixing by\n"//& - "unresolved eddies represented by MEKE. Can be negative to\n"//& + "If non-zero, is the scaling coefficient in the expression for "//& + "viscosity used to parameterize lateral momentum mixing by "//& + "unresolved eddies represented by MEKE. Can be negative to "//& "represent backscatter from the unresolved eddies.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_FIXED_MIXING_LENGTH", CS%Lfixed, & - "If positive, is a fixed length contribution to the expression\n"//& - "for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a fixed length contribution to the expression "//& + "for mixing length used in MEKE-derived diffusivity.", & units="m", default=0.0) call get_param(param_file, mdl, "MEKE_ALPHA_DEFORM", CS%aDeform, & - "If positive, is a coefficient weighting the deformation scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the deformation scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_ALPHA_RHINES", CS%aRhines, & - "If positive, is a coefficient weighting the Rhines scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the Rhines scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.05) call get_param(param_file, mdl, "MEKE_ALPHA_EADY", CS%aEady, & - "If positive, is a coefficient weighting the Eady length scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the Eady length scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.05) call get_param(param_file, mdl, "MEKE_ALPHA_FRICT", CS%aFrict, & - "If positive, is a coefficient weighting the frictional arrest scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the frictional arrest scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_ALPHA_GRID", CS%aGrid, & - "If positive, is a coefficient weighting the grid-spacing as a scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the grid-spacing as a scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_COLD_START", coldStart, & - "If true, initialize EKE to zero. Otherwise a local equilibrium solution\n"//& + "If true, initialize EKE to zero. Otherwise a local equilibrium solution "//& "is used as an initial condition for EKE.", default=.false.) call get_param(param_file, mdl, "MEKE_BACKSCAT_RO_C", MEKE%backscatter_Ro_c, & - "The coefficient in the Rossby number function for scaling the buharmonic\n"//& + "The coefficient in the Rossby number function for scaling the biharmonic "//& "frictional energy source. Setting to non-zero enables the Rossby number function.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_BACKSCAT_RO_POW", MEKE%backscatter_Ro_pow, & - "The power in the Rossby number function for scaling the biharmomnic\n"//& + "The power in the Rossby number function for scaling the biharmonic "//& "frictional energy source.", units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_ADVECTION_FACTOR", CS%MEKE_advection_factor, & - "A scale factor in front of advection of eddy energy. Zero turns advection off.\n"//& - "Using unity would be normal but other values could accomodate a mismatch\n"//& + "A scale factor in front of advection of eddy energy. Zero turns advection off. "//& + "Using unity would be normal but other values could accommodate a mismatch "//& "between the advecting barotropic flow and the vertical structure of MEKE.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_TOPOGRAPHIC_BETA", CS%MEKE_topographic_beta, & - "A scale factor to determine how much topographic beta is weighed in\n" //& - "computing beta in the expression of Rhines scale. Use 1 if full\n"//& + "A scale factor to determine how much topographic beta is weighed in " //& + "computing beta in the expression of Rhines scale. Use 1 if full "//& "topographic beta effect is considered; use 0 if it's completely ignored.", & units="nondim", default=0.0) ! Nonlocal module parameters call get_param(param_file, mdl, "CDRAG", CS%cdrag, & - "CDRAG is the drag coefficient relating the magnitude of \n"//& + "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", units="nondim", & default=0.003) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) @@ -1168,7 +1240,7 @@ end subroutine MEKE_end !! \f$ \gamma_\eta \in [0,1] \f$. !! !! The "frictional" source term -!! \f[ \dot{E}_{v} = \left< u \cdot \tau_h \right> \f] +!! \f[ \dot{E}_{v} = \left< \partial_i u_j \tau_{ij} \right> \f] !! equals the mean kinetic energy removed by lateral viscous fluxes, and !! is excluded/included in the MEKE budget by the efficiency parameter !! \f$ \gamma_v \in [0,1] \f$. @@ -1264,7 +1336,7 @@ end subroutine MEKE_end !! !! \f$L_c\f$ is a constant and \f$\delta[L_c]\f$ is the impulse function so that the term !! \f$\frac{\delta[L_c]}{L_c}\f$ evaluates to \f$\frac{1}{L_c}\f$ when \f$L_c\f$ is non-zero -!! but is dropped if \f$L_c=0\fi$. +!! but is dropped if \f$L_c=0\f$. !! !! \f$\beta^*\f$ is the effective \f$\beta\f$ that combines both the planetary vorticity !! gradient (i.e. \f$\beta=\nabla f\f$) and the topographic \f$\beta\f$ effect, diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index a980704d21..c43f6744d0 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -9,12 +9,13 @@ module MOM_hor_visc use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_io, only : MOM_read_data, slasher use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_NONE +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_io, only : MOM_read_data, slasher implicit none ; private @@ -70,6 +71,8 @@ module MOM_hor_visc real :: Kh_aniso !< The anisotropic viscosity [m2 s-1]. logical :: dynamic_aniso !< If true, the anisotropic viscosity is recomputed as a function !! of state. This is set depending on ANISOTROPIC_MODE. + logical :: res_scale_MEKE !< If true, the viscosity contribution from MEKE is scaled by + !! the resolution function. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx !< The background Laplacian viscosity at h points [m2 s-1]. !! The actual viscosity may be the larger of this @@ -175,7 +178,7 @@ module MOM_hor_visc !! u[is-2:ie+2,js-2:je+2] !! v[is-2:ie+2,js-2:je+2] !! h[is-1:ie+1,js-1:je+1] -subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, OBC) +subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, CS, OBC) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & @@ -194,6 +197,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, !! related to Mesoscale Eddy Kinetic Energy. type(VarMix_CS), pointer :: VarMix !< Pointer to a structure with fields that !! specify the spatially variable viscosities + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(hor_visc_CS), pointer :: CS !< Pontrol structure returned by a previous !! call to hor_visc_init. type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type @@ -265,6 +269,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, real :: RoScl ! The scaling function for MEKE source term [nondim] real :: FatH ! abs(f) at h-point for MEKE source term [s-1] real :: local_strain ! Local variable for interpolating computed strain rates [s-1]. + real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE. Otherwise =1. logical :: rescale_Kh, legacy_bound logical :: find_FrictWork @@ -325,6 +330,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, !$OMP bhstr_xx, bhstr_xy,FatH,RoScl, hu, hv, h_u, h_v, & !$OMP vort_xy,vort_xy_dx,vort_xy_dy,Vort_mag,AhLth,KhLth, & !$OMP div_xx, div_xx_dx, div_xx_dy, local_strain, & + !$OMP meke_res_fn, & !$OMP Shear_mag, h2uq, h2vq, hq, Kh_scale, hrat_min) do k=1,nz @@ -415,7 +421,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, endif endif if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - ! There are extra wide halos here to accomodate the cross-corner-point + ! There are extra wide halos here to accommodate the cross-corner-point ! OBC projections, but they might not be necessary if the accelerations ! are always zeroed out at OBC points, in which case the i-loop below ! becomes do i=is-1,ie+1. -RWH @@ -556,6 +562,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, endif; endif endif + meke_res_fn = 1. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then Shear_mag = sqrt(sh_xx(i,j)*sh_xx(i,j) + & @@ -583,10 +591,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, if (CS%Leith_Kh) Kh = max( Kh, CS%LAPLAC3_CONST_xx(i,j) * Vort_mag ) ! All viscosity contributions above are subject to resolution scaling if (rescale_Kh) Kh = VarMix%Res_fn_h(i,j) * Kh + if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_h(i,j) ! Older method of bounding for stability if (legacy_bound) Kh = min(Kh, CS%Kh_Max_xx(i,j)) Kh = max( Kh, CS%Kh_bg_min ) ! Place a floor on the viscosity, if desired. - if (use_MEKE_Ku) Kh = Kh + MEKE%Ku(i,j) ! *Add* the MEKE contribution (might be negative) + if (use_MEKE_Ku) Kh = Kh + MEKE%Ku(i,j) * meke_res_fn ! *Add* the MEKE contribution (might be negative) if (CS%anisotropic) Kh = Kh + CS%Kh_aniso * ( 1. - CS%n1n2_h(i,j)**2 ) ! *Add* the tension component ! of anisotropic viscosity @@ -629,7 +638,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, endif endif if (CS%Leith_Ah) & - AhLth = Vort_mag * (CS%BIHARM_CONST_xx(i,j)) + AhLth = Vort_mag * (CS%BIHARM5_CONST_xx(i,j)) Ah = MAX(MAX(CS%Ah_bg_xx(i,j), AhSm),AhLth) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & Ah = MIN(Ah, CS%Ah_Max_xx(i,j)) @@ -689,6 +698,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, endif ; endif endif + meke_res_fn = 1. + do J=js-1,Jeq ; do I=is-1,Ieq if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then Shear_mag = sqrt(sh_xy(I,J)*sh_xy(I,J) + & @@ -743,13 +754,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, if (CS%Leith_Kh) Kh = max( Kh, CS%LAPLAC3_CONST_xy(I,J) * Vort_mag) ! All viscosity contributions above are subject to resolution scaling if (rescale_Kh) Kh = VarMix%Res_fn_q(i,j) * Kh + if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_q(i,j) ! Older method of bounding for stability if (legacy_bound) Kh = min(Kh, CS%Kh_Max_xy(i,j)) Kh = max( Kh, CS%Kh_bg_min ) ! Place a floor on the viscosity, if desired. if (use_MEKE_Ku) then ! *Add* the MEKE contribution (might be negative) Kh = Kh + 0.25*( (MEKE%Ku(I,J)+MEKE%Ku(I+1,J+1)) & - +(MEKE%Ku(I+1,J)+MEKE%Ku(I,J+1)) ) + +(MEKE%Ku(I+1,J)+MEKE%Ku(I,J+1)) ) * meke_res_fn endif + ! Older method of bounding for stability if (CS%anisotropic) Kh = Kh + CS%Kh_aniso * CS%n1n2_q(I,J)**2 ! *Add* the shear component ! of anisotropic viscosity @@ -864,7 +877,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, endif if (find_FrictWork) then ; do j=js,je ; do i=is,ie - ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) + ! Diagnose str_xx*d_x u + str_yy*d_y v + str_xy*(d_y u + d_x v) FrictWork(i,j,k) = GV%H_to_kg_m2 * ( & (str_xx(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & -str_xx(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & @@ -893,12 +906,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, endif if (MEKE%backscatter_Ro_c /= 0.) then do j=js,je ; do i=is,ie - FatH = 0.25*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) & - +(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) ) + FatH = 0.25*US%s_to_T*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) ) Shear_mag = sqrt(sh_xx(i,j)*sh_xx(i,j) + & 0.25*((sh_xy(I-1,J-1)*sh_xy(I-1,J-1) + sh_xy(I,J)*sh_xy(I,J)) + & (sh_xy(I-1,J)*sh_xy(I-1,J) + sh_xy(I,J-1)*sh_xy(I,J-1)))) FatH = FatH ** MEKE%backscatter_Ro_pow ! f^n + !### Note the hard-coded dimensional constant in the following line. Shear_mag = ( ( Shear_mag ** MEKE%backscatter_Ro_pow ) + 1.e-30 ) & * MEKE%backscatter_Ro_c ! c * D^n ! The Rossby number function is g(Ro) = 1/(1+c.Ro^n) @@ -953,9 +967,10 @@ end subroutine horizontal_viscosity !> Allocates space for and calculates static variables used by horizontal_viscosity(). !! hor_visc_init calculates and stores the values of a number of metric functions that !! are used in horizontal_viscosity(). -subroutine hor_visc_init(Time, G, param_file, diag, CS) +subroutine hor_visc_init(Time, G, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. @@ -980,6 +995,7 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) real :: Ah ! biharmonic horizontal viscosity [m4 s-1] real :: Kh_vel_scale ! this speed [m s-1] times grid spacing gives Lap visc real :: Ah_vel_scale ! this speed [m s-1] times grid spacing cubed gives bih visc + real :: Ah_time_scale ! damping time-scale for biharmonic visc real :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant real :: Leith_Lap_const ! nondimensional Laplacian Leith constant @@ -1053,18 +1069,18 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) "The minimum value allowed for Laplacian horizontal viscosity, KH.", & units = "m2 s-1", default=0.0) call get_param(param_file, mdl, "KH_VEL_SCALE", Kh_vel_scale, & - "The velocity scale which is multiplied by the grid \n"//& - "spacing to calculate the Laplacian viscosity. \n"//& - "The final viscosity is the largest of this scaled \n"//& + "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 and Leith viscosities, and KH.", & units="m s-1", default=0.0) call get_param(param_file, mdl, "KH_SIN_LAT", Kh_sin_lat, & - "The amplitude of a latidutinally-dependent background\n"//& + "The amplitude of a latitudinally-dependent background "//& "viscosity of the form KH_SIN_LAT*(SIN(LAT)**KH_PWR_OF_SINE).", & units = "m2 s-1", default=0.0) if (Kh_sin_lat>0. .or. get_all) & call get_param(param_file, mdl, "KH_PWR_OF_SINE", Kh_pwr_of_sine, & - "The power used to raise SIN(LAT) when using a latidutinally-\n"//& + "The power used to raise SIN(LAT) when using a latitudinally "//& "dependent background viscosity.", & units = "nondim", default=4.0) @@ -1073,7 +1089,7 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) default=.false.) if (CS%Smagorinsky_Kh .or. get_all) & call get_param(param_file, mdl, "SMAG_LAP_CONST", Smag_Lap_const, & - "The nondimensional Laplacian Smagorinsky constant, \n"//& + "The nondimensional Laplacian Smagorinsky constant, "//& "often 0.15.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Kh) @@ -1082,25 +1098,28 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) default=.false.) call get_param(param_file, mdl, "MODIFIED_LEITH", CS%Modified_Leith, & - "If true, add a term to Leith viscosity which is \n"//& + "If true, add a term to Leith viscosity which is "//& "proportional to the gradient of divergence.", & default=.false.) + call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & + "If true, the viscosity contribution from MEKE is scaled by "//& + "the resolution function.", default=.false.) if (CS%Leith_Kh .or. get_all) & call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & - "The nondimensional Laplacian Leith constant, \n"//& + "The nondimensional Laplacian Leith constant, "//& "often ??", units="nondim", default=0.0, & fail_if_missing = CS%Leith_Kh) call get_param(param_file, mdl, "BOUND_KH", CS%bound_Kh, & - "If true, the Laplacian coefficient is locally limited \n"//& + "If true, the Laplacian coefficient is locally limited "//& "to be stable.", default=.true.) call get_param(param_file, mdl, "BETTER_BOUND_KH", CS%better_bound_Kh, & - "If true, the Laplacian coefficient is locally limited \n"//& + "If true, the Laplacian coefficient is locally limited "//& "to be stable with a better bounding than just BOUND_KH.", & default=CS%bound_Kh) call get_param(param_file, mdl, "ANISOTROPIC_VISCOSITY", CS%anisotropic, & - "If true, allow anistropic viscosity in the Laplacian\n"//& + "If true, allow anistropic viscosity in the Laplacian "//& "horizontal viscosity.", default=.false.) endif if (CS%anisotropic .or. get_all) then @@ -1116,19 +1135,19 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) select case (aniso_mode) case (0) call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for\n"//& - "horizont viscosity. n1,n2 are the i,j components relative\n"//& + "The vector pointing in the direction of anistropy for "//& + "horizont viscosity. n1,n2 are the i,j components relative "//& "to the grid.", units = "nondim", fail_if_missing=.true.) case (1) call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for\n"//& - "horizont viscosity. n1,n2 are the i,j components relative\n"//& + "The vector pointing in the direction of anistropy for "//& + "horizont viscosity. n1,n2 are the i,j components relative "//& "to the spherical coordinates.", units = "nondim", fail_if_missing=.true.) end select endif call get_param(param_file, mdl, "BIHARMONIC", CS%biharmonic, & - "If true, use a biharmonic horizontal viscosity. \n"//& + "If true, use a biharmonic horizontal viscosity. "//& "BIHARMONIC may be used with LAPLACIAN.", & default=.true.) if (CS%biharmonic .or. get_all) then @@ -1136,46 +1155,52 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) "The background biharmonic horizontal viscosity.", & units = "m4 s-1", default=0.0) call get_param(param_file, mdl, "AH_VEL_SCALE", Ah_vel_scale, & - "The velocity scale which is multiplied by the cube of \n"//& - "the grid spacing to calculate the biharmonic viscosity. \n"//& - "The final viscosity is the largest of this scaled \n"//& + "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.", & units="m s-1", default=0.0) + call get_param(param_file, mdl, "AH_TIME_SCALE", Ah_time_scale, & + "A time scale whose inverse is multiplied by the fourth "//& + "power of the grid spacing to calculate biharmonic viscosity. "//& + "The final viscosity is the largest of all viscosity "//& + "formulations in use. 0.0 means that it's not used.", & + units="s", default=0.0) call get_param(param_file, mdl, "SMAGORINSKY_AH", CS%Smagorinsky_Ah, & - "If true, use a biharmonic Smagorinsky nonlinear eddy \n"//& + "If true, use a biharmonic Smagorinsky nonlinear eddy "//& "viscosity.", default=.false.) call get_param(param_file, mdl, "LEITH_AH", CS%Leith_Ah, & - "If true, use a biharmonic Leith nonlinear eddy \n"//& + "If true, use a biharmonic Leith nonlinear eddy "//& "viscosity.", default=.false.) call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, & - "If true, the biharmonic coefficient is locally limited \n"//& + "If true, the biharmonic coefficient is locally limited "//& "to be stable.", default=.true.) call get_param(param_file, mdl, "BETTER_BOUND_AH", CS%better_bound_Ah, & - "If true, the biharmonic coefficient is locally limited \n"//& + "If true, the biharmonic coefficient is locally limited "//& "to be stable with a better bounding than just BOUND_AH.", & default=CS%bound_Ah) if (CS%Smagorinsky_Ah .or. get_all) then call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & - "The nondimensional biharmonic Smagorinsky constant, \n"//& + "The nondimensional biharmonic Smagorinsky constant, "//& "typically 0.015 - 0.06.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Ah) call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.) call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, & - "If true use a viscosity that increases with the square \n"//& - "of the velocity shears, so that the resulting viscous \n"//& - "drag is of comparable magnitude to the Coriolis terms \n"//& - "when the velocity differences between adjacent grid \n"//& - "points is 0.5*BOUND_CORIOLIS_VEL. The default is the \n"//& + "If true use a viscosity that increases with the square "//& + "of the velocity shears, so that the resulting viscous "//& + "drag is of comparable magnitude to the Coriolis terms "//& + "when the velocity differences between adjacent grid "//& + "points is 0.5*BOUND_CORIOLIS_VEL. The default is the "//& "value of BOUND_CORIOLIS (or false).", default=bound_Cor_def) if (CS%bound_Coriolis .or. get_all) then call get_param(param_file, mdl, "MAXVEL", maxvel, default=3.0e8) bound_Cor_vel = maxvel call get_param(param_file, mdl, "BOUND_CORIOLIS_VEL", bound_Cor_vel, & - "The velocity scale at which BOUND_CORIOLIS_BIHARM causes \n"//& - "the biharmonic drag to have comparable magnitude to the \n"//& + "The velocity scale at which BOUND_CORIOLIS_BIHARM causes "//& + "the biharmonic drag to have comparable magnitude to the "//& "Coriolis acceleration. The default is set by MAXVEL.", & units="m s-1", default=maxvel) endif @@ -1183,7 +1208,7 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) if (CS%Leith_Ah .or. get_all) then call get_param(param_file, mdl, "LEITH_BI_CONST",Leith_bi_const, & - "The nondimensional biharmonic Leith constant, \n"//& + "The nondimensional biharmonic Leith constant, "//& "typical values are thus far undetermined", units="nondim", default=0.0, & fail_if_missing = CS%Leith_Ah) endif @@ -1191,41 +1216,41 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) endif call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, & - "If true, use Use the land mask for the computation of thicknesses \n"//& - "at velocity locations. This eliminates the dependence on arbitrary \n"//& - "values over land or outside of the domain. Default is False in order to \n"//& - "maintain answers with legacy experiments but should be changed to True \n"//& + "If true, use 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. Default is False in order to "//& + "maintain answers with legacy experiments but should be changed to True "//& "for new experiments.", default=.false.) if (CS%better_bound_Ah .or. CS%better_bound_Kh .or. get_all) & call get_param(param_file, mdl, "HORVISC_BOUND_COEF", CS%bound_coef, & - "The nondimensional coefficient of the ratio of the \n"//& - "viscosity bounds to the theoretical maximum for \n"//& + "The nondimensional coefficient of the ratio of the "//& + "viscosity bounds to the theoretical maximum for "//& "stability without considering other terms.", units="nondim", & default=0.8) call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & - "If true, no slip boundary conditions are used; otherwise \n"//& - "free slip boundary conditions are assumed. The \n"//& - "implementation of the free slip BCs on a C-grid is much \n"//& - "cleaner than the no slip BCs. The use of free slip BCs \n"//& - "is strongly encouraged, and no slip BCs are not used with \n"//& + "If true, no slip boundary conditions are used; otherwise "//& + "free slip boundary conditions are assumed. The "//& + "implementation of the free slip BCs on a C-grid is much "//& + "cleaner than the no slip BCs. The use of free slip BCs "//& + "is strongly encouraged, and no slip BCs are not used with "//& "the biharmonic viscosity.", default=.false.) call get_param(param_file, mdl, "USE_KH_BG_2D", CS%use_Kh_bg_2d, & - "If true, read a file containing 2-d background harmonic \n"//& + "If true, read a file containing 2-d background harmonic "//& "viscosities. The final viscosity is the maximum of the other "//& "terms and this background value.", default=.false.) if (CS%bound_Kh .or. CS%bound_Ah .or. CS%better_bound_Kh .or. CS%better_bound_Ah) & call get_param(param_file, mdl, "DT", dt, & - "The (baroclinic) dynamics time step.", units = "s", & + "The (baroclinic) dynamics time step.", units="s", & fail_if_missing=.true.) if (CS%no_slip .and. CS%biharmonic) & call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & - "at the same time in MOM.") + "at the same time in MOM.") if (.not.(CS%Laplacian .or. CS%biharmonic)) then ! Only issue inviscid warning if not in single column mode (usually 2x2 domain) @@ -1447,8 +1472,8 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) if (CS%Smagorinsky_Ah) then CS%BIHARM_CONST_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2) if (CS%bound_Coriolis) then - fmax = MAX(abs(G%CoriolisBu(I-1,J-1)), abs(G%CoriolisBu(I,J-1)), & - abs(G%CoriolisBu(I-1,J)), abs(G%CoriolisBu(I,J))) + fmax = US%s_to_T*MAX(abs(G%CoriolisBu(I-1,J-1)), abs(G%CoriolisBu(I,J-1)), & + abs(G%CoriolisBu(I-1,J)), abs(G%CoriolisBu(I,J))) CS%Biharm_Const2_xx(i,j) = (grid_sp_h2 * grid_sp_h2 * grid_sp_h2) * & (fmax * BoundCorConst) endif @@ -1458,6 +1483,8 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) endif CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) + if (Ah_time_scale>0.) CS%Ah_bg_xx(i,j) = & + MAX(CS%Ah_bg_xx(i,j), (grid_sp_h2 * grid_sp_h2) / Ah_time_scale) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then CS%Ah_Max_xx(i,j) = Ah_Limit * (grid_sp_h2 * grid_sp_h2) CS%Ah_bg_xx(i,j) = MIN(CS%Ah_bg_xx(i,j), CS%Ah_Max_xx(i,j)) @@ -1471,7 +1498,7 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) CS%BIHARM_CONST_xy(I,J) = Smag_bi_const * (grid_sp_q2 * grid_sp_q2) if (CS%bound_Coriolis) then CS%Biharm_Const2_xy(I,J) = (grid_sp_q2 * grid_sp_q2 * grid_sp_q2) * & - (abs(G%CoriolisBu(I,J)) * BoundCorConst) + (abs(US%s_to_T*G%CoriolisBu(I,J)) * BoundCorConst) endif endif @@ -1480,6 +1507,8 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) + if (Ah_time_scale>0.) CS%Ah_bg_xy(i,j) = & + MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then CS%Ah_Max_xy(I,J) = Ah_Limit * (grid_sp_q2 * grid_sp_q2) CS%Ah_bg_xy(I,J) = MIN(CS%Ah_bg_xy(I,J), CS%Ah_Max_xy(I,J)) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 4052f948a3..fb35d5b45c 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -108,10 +108,6 @@ module MOM_internal_tides !< The internal wave energy density as a function of (i,j,angle); temporary for restart real, allocatable, dimension(:) :: frequency !< The frequency of each band [s-1]. - !### Delete later - real :: int_tide_source_x !< X Location of generation site for internal tide testing - real :: int_tide_source_y !< Y Location of generation site for internal tide testing - type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. type(wave_structure_CS), pointer :: wave_structure_CSp => NULL() @@ -214,8 +210,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%energized_angle <= 0) then frac_per_sector = 1.0 / real(CS%nAngle * CS%nMode * CS%nFreq) do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + f2 = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + & dt*frac_per_sector*(1-CS%q_itides)*TKE_itidal_input(i,j) @@ -224,8 +220,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & frac_per_sector = 1.0 / real(CS%nMode * CS%nFreq) a = CS%energized_angle do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + f2 = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + & dt*frac_per_sector**(1-CS%q_itides)*TKE_itidal_input(i,j) @@ -245,7 +241,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Apply half the refraction. do m=1,CS%nMode ; do fr=1,CS%nFreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, G, CS%nAngle, CS%use_PPMang) + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, G, US, CS%nAngle, CS%use_PPMang) enddo ; enddo ! Check for En<0 - for debugging, delete later @@ -271,7 +267,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Propagate the waves. do m=1,CS%NMode ; do fr=1,CS%Nfreq - call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, G, CS, CS%NAngle) + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, G, US, CS, CS%NAngle) enddo ; enddo ! Check for En<0 - for debugging, delete later @@ -292,7 +288,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Apply the other half of the refraction. do m=1,CS%NMode ; do fr=1,CS%Nfreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, G, CS%NAngle, CS%use_PPMang) + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, G, US, CS%NAngle, CS%use_PPMang) enddo ; enddo ! Check for En<0 - for debugging, delete later @@ -421,8 +417,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=jsd,jed ; do i=isd,ied id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging ! Calculate horizontal phase velocity magnitudes - f2 = 0.25*(G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J)**2 + & - G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J-1)**2 ) + f2 = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) c_phase = 0.0 if (Kmag2 > 0.0) then @@ -730,7 +726,7 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) end subroutine get_lowmode_loss !> Implements refraction on the internal waves at a single frequency. -subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) +subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -742,6 +738,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) intent(in) :: cn !< Baroclinic mode speed [m s-1]. real, intent(in) :: freq !< Wave frequency [s-1]. real, intent(in) :: dt !< Time step [s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: use_PPMang !< If true, use PPM for advection rather !! than upwind. ! Local variables @@ -795,24 +792,24 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) ! Do the refraction. do i=is,ie - f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + f2 = 0.25*US%s_to_T**2 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) - favg = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & - (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J))) - df2_dx = 0.5*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I,J-1)**2) - & + favg = 0.25*US%s_to_T*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J))) + df2_dx = 0.5*US%s_to_T**2 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I,J-1)**2) - & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I-1,J-1)**2)) * & G%IdxT(i,j) - df_dx = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) - & + df_dx = 0.5*US%s_to_T*((G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) - & (G%CoriolisBu(I-1,J) + G%CoriolisBu(I-1,J-1))) * & G%IdxT(i,j) dlnCn_dx = 0.5*( G%IdxCu(I,j) * (cn(i+1,j) - cn(i,j)) / & (0.5*(cn(i+1,j) + cn(i,j)) + cn_subRO) + & G%IdxCu(I-1,j) * (cn(i,j) - cn(i-1,j)) / & (0.5*(cn(i,j) + cn(i-1,j)) + cn_subRO) ) - df2_dy = 0.5*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J)**2) - & + df2_dy = 0.5*US%s_to_T**2 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J)**2) - & (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J-1)**2)) * & G%IdyT(i,j) - df_dy = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) - & + df_dy = 0.5*US%s_to_T*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) - & (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J-1))) * & G%IdyT(i,j) dlnCn_dy = 0.5*( G%IdyCv(i,J) * (cn(i,j+1) - cn(i,j)) / & @@ -950,7 +947,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) end subroutine PPM_angular_advect !> Propagates internal waves at a single frequency. -subroutine propagate(En, cn, freq, dt, G, CS, NAngle) +subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -962,6 +959,7 @@ subroutine propagate(En, cn, freq, dt, G, CS, NAngle) intent(in) :: cn !< Baroclinic mode speed [m s-1]. real, intent(in) :: freq !< Wave frequency [s-1]. real, intent(in) :: dt !< Time step [s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), pointer :: CS !< The control structure returned by a !! previous call to int_tide_init. ! Local variables @@ -1012,7 +1010,7 @@ subroutine propagate(En, cn, freq, dt, G, CS, NAngle) ! Fix indexing here later speed(:,:) = 0 do J=jsh-1,jeh ; do I=ish-1,ieh - f2 = G%CoriolisBu(I,J)**2 + f2 = US%s_to_T**2 * G%CoriolisBu(I,J)**2 speed(I,J) = 0.25*(cn(i,j) + cn(i+1,j) + cn(i+1,j+1) + cn(i,j+1)) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo @@ -1042,12 +1040,12 @@ subroutine propagate(En, cn, freq, dt, G, CS, NAngle) enddo do j=jsh,jeh ; do I=ish-1,ieh - f2 = 0.5*(G%CoriolisBu(I,J)**2 + G%CoriolisBu(I,J-1)**2) + f2 = 0.5*US%s_to_T**2 * (G%CoriolisBu(I,J)**2 + G%CoriolisBu(I,J-1)**2) speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo do J=jsh-1,jeh ; do i=ish,ieh - f2 = 0.5*(G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J)**2) + f2 = 0.5*US%s_to_T**2 * (G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J)**2) speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo @@ -1810,7 +1808,7 @@ subroutine teleport(En, NAngle, CS, G, LB) end subroutine teleport -!> Rotates points in the halos where required to accomodate +!> Rotates points in the halos where required to accommodate !! changes in grid orientation, such as at the tripolar fold. subroutine correct_halo_rotation(En, test, G, NAngle) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -2193,13 +2191,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "INTERNAL_TIDE_FREQS", num_freq, & - "The number of distinct internal tide frequency bands \n"//& + "The number of distinct internal tide frequency bands "//& "that will be calculated.", default=1) call get_param(param_file, mdl, "INTERNAL_TIDE_MODES", num_mode, & - "The number of distinct internal tide modes \n"//& + "The number of distinct internal tide modes "//& "that will be calculated.", default=1) call get_param(param_file, mdl, "INTERNAL_TIDE_ANGLES", num_angle, & - "The number of angular resolution bands for the internal \n"//& + "The number of angular resolution bands for the internal "//& "tide calculations.", default=24) if (use_int_tides) then @@ -2229,34 +2227,34 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", CS%decay_rate, & - "The rate at which internal tide energy is lost to the \n"//& + "The rate at which internal tide energy is lost to the "//& "interior ocean internal wave field.", units="s-1", default=0.0) call get_param(param_file, mdl, "INTERNAL_TIDE_VOLUME_BASED_CFL", CS%vol_CFL, & - "If true, use the ratio of the open face lengths to the \n"//& - "tracer cell areas when estimating CFL numbers in the \n"//& + "If true, use the ratio of the open face lengths to the "//& + "tracer cell areas when estimating CFL numbers in the "//& "internal tide code.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_CORNER_ADVECT", CS%corner_adv, & - "If true, internal tide ray-tracing advection uses a \n"//& - " corner-advection scheme rather than PPM.\n", default=.false.) + "If true, internal tide ray-tracing advection uses a "//& + "corner-advection scheme rather than PPM.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_SIMPLE_2ND_PPM", CS%simple_2nd, & - "If true, CONTINUITY_PPM uses a simple 2nd order \n"//& - "(arithmetic mean) interpolation of the edge values. \n"//& - "This may give better PV conservation propterties. While \n"//& - "it formally reduces the accuracy of the continuity \n"//& - "solver itself in the strongly advective limit, it does \n"//& - "not reduce the overall order of accuracy of the dynamic \n"//& + "If true, CONTINUITY_PPM uses a simple 2nd order "//& + "(arithmetic mean) interpolation of the edge values. "//& + "This may give better PV conservation properties. 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.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_UPWIND_1ST", CS%upwind_1st, & - "If true, the internal tide ray-tracing advection uses \n"//& - "1st-order upwind advection. This scheme is highly \n"//& - "continuity solver. This scheme is highly \n"//& + "If true, the internal tide ray-tracing advection uses "//& + "1st-order upwind advection. This scheme is highly "//& + "continuity solver. This scheme is highly "//& "diffusive but may be useful for debugging.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_BACKGROUND_DRAG", & - CS%apply_background_drag, "If true, the internal tide \n"//& + CS%apply_background_drag, "If true, the internal tide "//& "ray-tracing advection uses a background drag term as a sink.",& default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_QUAD_DRAG", CS%apply_bottom_drag, & - "If true, the internal tide ray-tracing advection uses \n"//& + "If true, the internal tide ray-tracing advection uses "//& "a quadratic bottom drag term as a sink.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_WAVE_DRAG", CS%apply_wave_drag, & "If true, apply scattering due to small-scale roughness as a sink.", & @@ -2265,22 +2263,22 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "If true, apply wave breaking as a sink.", & default=.false.) call get_param(param_file, mdl, "CDRAG", CS%cdrag, & - "CDRAG is the drag coefficient relating the magnitude of \n"//& + "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", units="nondim", & default=0.003) call get_param(param_file, mdl, "INTERNAL_TIDE_ENERGIZED_ANGLE", CS%energized_angle, & - "If positive, only one angular band of the internal tides \n"//& + "If positive, only one angular band of the internal tides "//& "gets all of the energy. (This is for debugging.)", default=-1) call get_param(param_file, mdl, "USE_PPM_ANGULAR", CS%use_PPMang, & - "If true, use PPM for advection of energy in angular \n"//& - "space.", default=.false.) + "If true, use PPM for advection of energy in angular space.", & + default=.false.) call get_param(param_file, mdl, "GAMMA_ITIDES", CS%q_itides, & - "The fraction of the internal tidal energy that is \n"//& - "dissipated locally with INT_TIDE_DISSIPATION. \n"//& + "The fraction of the internal tidal energy that is "//& + "dissipated locally with INT_TIDE_DISSIPATION. "//& "THIS NAME COULD BE BETTER.", & units="nondim", default=0.3333) call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & - "A topographic wavenumber used with INT_TIDE_DISSIPATION. \n"//& + "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & units="m-1", default=8.e-4*atan(1.0)) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & @@ -2306,7 +2304,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Compute the fixed part of the bottom drag loss from baroclinic modes call get_param(param_file, mdl, "H2_FILE", h2_file, & - "The path to the file containing the sub-grid-scale \n"//& + "The path to the file containing the sub-grid-scale "//& "topographic roughness amplitude with INT_TIDE_DISSIPATION.", & fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) @@ -2325,7 +2323,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in prescribed coast/ridge/shelf angles from file call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & - "The path to the file containing the local angle of \n"//& + "The path to the file containing the local angle of "//& "the coastline/ridge/shelf with respect to the equator.", & fail_if_missing=.false.) filename = trim(CS%inputdir) // trim(refl_angle_file) @@ -2413,12 +2411,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !call MOM_read_data(filename, 'dx_Cv', G%dx_Cv, G%domain, timelevel=1) !call pass_var(G%dx_Cv,G%domain) - ! For debugging - delete later - call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & - "X Location of generation site for internal tide", default=1.) - call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & - "Y Location of generation site for internal tide", default=1.) - ! Register maps of reflection parameters CS%id_refl_ang = register_diag_field('ocean_model', 'refl_angle', diag%axesT1, & Time, 'Local angle of coastline/ridge/shelf with respect to equator', 'rad') @@ -2445,7 +2437,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) Time, 'Interior and bottom drag internal tide decay timescale', 's-1') !Register 2-D energy input into internal tides CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & - Time, 'Conversion from barotropic to baroclinic tide, \n'//& + Time, 'Conversion from barotropic to baroclinic tide, '//& 'a fraction of which goes into rays', 'W m-2') ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 3f250bc935..2a855f4416 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -719,7 +719,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! Local variables real :: KhTr_Slope_Cff, KhTh_Slope_Cff, oneOrTwo, N2_filter_depth real :: KhTr_passivity_coeff - real, parameter :: absurdly_small_freq2 = 1e-34 ! A miniscule frequency + real :: absurdly_small_freq2 ! A miniscule frequency ! squared that is used to avoid division by 0 [s-2]. This ! value is roughly (pi / (the age of the universe) )^2. logical :: Gill_equatorial_Ld, use_FGNV_streamfn, use_MEKE, in_use @@ -747,46 +747,47 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_Rd_dx = .false. CS%calculate_res_fns = .false. CS%calculate_Eady_growth_rate = .false. + absurdly_small_freq2 = 1e-34 !### Note the hard-coded dimensional parameter. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_VARIABLE_MIXING", CS%use_variable_mixing,& - "If true, the variable mixing code will be called. This \n"//& - "allows diagnostics to be created even if the scheme is \n"//& - "not used. If KHTR_SLOPE_CFF>0 or KhTh_Slope_Cff>0, \n"//& - "this is set to true regardless of what is in the \n"//& + "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.", default=.false.) call get_param(param_file, mdl, "RESOLN_SCALED_KH", CS%Resoln_scaled_Kh, & - "If true, the Laplacian lateral viscosity is scaled away \n"//& - "when the first baroclinic deformation radius is well \n"//& + "If true, the Laplacian lateral viscosity is scaled away "//& + "when the first baroclinic deformation radius is well "//& "resolved.", default=.false.) call get_param(param_file, mdl, "RESOLN_SCALED_KHTH", CS%Resoln_scaled_KhTh, & - "If true, the interface depth diffusivity is scaled away \n"//& - "when the first baroclinic deformation radius is well \n"//& + "If true, the interface depth diffusivity is scaled away "//& + "when the first baroclinic deformation radius is well "//& "resolved.", default=.false.) call get_param(param_file, mdl, "RESOLN_SCALED_KHTR", CS%Resoln_scaled_KhTr, & - "If true, the epipycnal tracer diffusivity is scaled \n"//& - "away when the first baroclinic deformation radius is \n"//& + "If true, the epipycnal tracer diffusivity is scaled "//& + "away when the first baroclinic deformation radius is "//& "well resolved.", default=.false.) call get_param(param_file, mdl, "RESOLN_USE_EBT", CS%Resoln_use_ebt, & - "If true, uses the equivalent barotropic wave speed instead\n"//& + "If true, uses the equivalent barotropic wave speed instead "//& "of first baroclinic wave for calculating the resolution fn.",& default=.false.) call get_param(param_file, mdl, "KHTH_USE_EBT_STRUCT", CS%khth_use_ebt_struct, & - "If true, uses the equivalent barotropic structure\n"//& + "If true, uses the equivalent barotropic structure "//& "as the vertical structure of thickness diffusivity.",& default=.false.) call get_param(param_file, mdl, "KHTH_SLOPE_CFF", KhTh_Slope_Cff, & - "The nondimensional coefficient in the Visbeck formula \n"//& + "The nondimensional coefficient in the Visbeck formula "//& "for the interface depth diffusivity", units="nondim", & default=0.0) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", KhTr_Slope_Cff, & - "The nondimensional coefficient in the Visbeck formula \n"//& + "The nondimensional coefficient in the Visbeck formula "//& "for the epipycnal tracer diffusivity", units="nondim", & default=0.0) call get_param(param_file, mdl, "USE_STORED_SLOPES", CS%use_stored_slopes,& - "If true, the isopycnal slopes are calculated once and\n"//& - "stored for re-use. This uses more memory but avoids calling\n"//& + "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 should be necessary.", & default=.false.) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", use_FGNV_streamfn, & @@ -808,7 +809,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) then in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & - "The depth below which N2 is monotonized to avoid stratification\n"//& + "The depth below which N2 is monotonized to avoid stratification "//& "artifacts from altering the equivalent barotropic mode structure.",& units='m', default=2000.) allocate(CS%ebt_struct(isd:ied,jsd:jed,G%ke)) ; CS%ebt_struct(:,:,:) = 0.0 @@ -817,8 +818,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then CS%calculate_Eady_growth_rate = .true. call get_param(param_file, mdl, "VISBECK_MAX_SLOPE", CS%Visbeck_S_max, & - "If non-zero, is an upper bound on slopes used in the\n"// & - "Visbeck formula for diffusivity. This does not affect the\n"// & + "If non-zero, is an upper bound on slopes used in the "//& + "Visbeck formula for diffusivity. This does not affect the "//& "isopycnal slope calculation used within thickness diffusion.", & units="nondim", default=0.0) endif @@ -828,7 +829,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%slope_x(IsdB:IedB,jsd:jed,G%ke+1)) ; CS%slope_x(:,:,:) = 0.0 allocate(CS%slope_y(isd:ied,JsdB:JedB,G%ke+1)) ; CS%slope_y(:,:,:) = 0.0 call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & - "A diapycnal diffusivity that is used to interpolate \n"//& + "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & default=1.0e-6, scale=US%m_to_Z**2) !### Add units argument. endif @@ -842,7 +843,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%id_SN_v = register_diag_field('ocean_model', 'SN_v', diag%axesCv1, Time, & 'Inverse eddy time-scale, S*N, at v-points', 's-1') call get_param(param_file, mdl, "VARMIX_KTOP", CS%VarMix_Ktop, & - "The layer number at which to start vertical integration \n"//& + "The layer number at which to start vertical integration "//& "of S*N for purposes of finding the Eady growth rate.", & units="nondim", default=2) endif @@ -852,8 +853,19 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "VISBECK_L_SCALE", CS%Visbeck_L_scale, & "The fixed length scale in the Visbeck formula.", units="m", & default=0.0) - allocate(CS%L2u(IsdB:IedB,jsd:jed)) ; CS%L2u(:,:) = CS%Visbeck_L_scale**2 - allocate(CS%L2v(isd:ied,JsdB:JedB)) ; CS%L2v(:,:) = CS%Visbeck_L_scale**2 + allocate(CS%L2u(IsdB:IedB,jsd:jed)) ; CS%L2u(:,:) = 0.0 + allocate(CS%L2v(isd:ied,JsdB:JedB)) ; CS%L2v(:,:) = 0.0 + if (CS%Visbeck_L_scale<0) then + do j=js,je ; do I=is-1,Ieq + CS%L2u(I,j) = CS%Visbeck_L_scale**2*G%areaCu(I,j) + enddo; enddo + do J=js-1,Jeq ; do i=is,ie + CS%L2v(i,J) = CS%Visbeck_L_scale**2*G%areaCv(i,J) + enddo; enddo + else + CS%L2u(:,:) = CS%Visbeck_L_scale**2 + CS%L2v(:,:) = CS%Visbeck_L_scale**2 + endif CS%id_L2u = register_diag_field('ocean_model', 'L2u', diag%axesCu1, Time, & 'Length scale squared for mixing coefficient, at u-points', 'm2') @@ -890,39 +902,39 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Resolution function for scaling diffusivities', 'nondim') call get_param(param_file, mdl, "KH_RES_SCALE_COEF", CS%Res_coef_khth, & - "A coefficient that determines how KhTh is scaled away if \n"//& - "RESOLN_SCALED_... is true, as \n"//& + "A coefficient that determines how KhTh is scaled away if "//& + "RESOLN_SCALED_... is true, as "//& "F = 1 / (1 + (KH_RES_SCALE_COEF*Rd/dx)^KH_RES_FN_POWER).", & units="nondim", default=1.0) call get_param(param_file, mdl, "KH_RES_FN_POWER", CS%Res_fn_power_khth, & - "The power of dx/Ld in the Kh resolution function. Any \n"//& - "positive integer may be used, although even integers \n"//& - "are more efficient to calculate. Setting this greater \n"//& + "The power of dx/Ld in the Kh resolution function. Any "//& + "positive integer may be used, although even integers "//& + "are more efficient to calculate. Setting this greater "//& "than 100 results in a step-function being used.", & units="nondim", default=2) call get_param(param_file, mdl, "VISC_RES_SCALE_COEF", CS%Res_coef_visc, & - "A coefficient that determines how Kh is scaled away if \n"//& - "RESOLN_SCALED_... is true, as \n"//& - "F = 1 / (1 + (KH_RES_SCALE_COEF*Rd/dx)^KH_RES_FN_POWER).\n"//& + "A coefficient that determines how Kh is scaled away if "//& + "RESOLN_SCALED_... is true, as "//& + "F = 1 / (1 + (KH_RES_SCALE_COEF*Rd/dx)^KH_RES_FN_POWER). "//& "This function affects lateral viscosity, Kh, and not KhTh.", & units="nondim", default=CS%Res_coef_khth) call get_param(param_file, mdl, "VISC_RES_FN_POWER", CS%Res_fn_power_visc, & - "The power of dx/Ld in the Kh resolution function. Any \n"//& - "positive integer may be used, although even integers \n"//& - "are more efficient to calculate. Setting this greater \n"//& - "than 100 results in a step-function being used.\n"//& + "The power of dx/Ld in the Kh resolution function. Any "//& + "positive integer may be used, although even integers "//& + "are more efficient to calculate. Setting this greater "//& + "than 100 results in a step-function being used. "//& "This function affects lateral viscosity, Kh, and not KhTh.", & units="nondim", default=CS%Res_fn_power_khth) call get_param(param_file, mdl, "INTERPOLATE_RES_FN", CS%interpolate_Res_fn, & - "If true, interpolate the resolution function to the \n"//& - "velocity points from the thickness points; otherwise \n"//& - "interpolate the wave speed and calculate the resolution \n"//& + "If true, interpolate the resolution function to the "//& + "velocity points from the thickness points; otherwise "//& + "interpolate the wave speed and calculate the resolution "//& "function independently at each point.", default=.true.) call get_param(param_file, mdl, "USE_VISBECK_SLOPE_BUG", CS%use_Visbeck_slope_bug, & - "If true, then retain a legacy bug in the calculation of weights \n"//& - "applied to isoneutral slopes. There was an erroneous k-indexing \n"//& - "for layer thicknesses. In addition, masking at coastlines was not \n"//& - "used which introduced potential restart issues. This flag will be \n"//& + "If true, then retain a legacy bug in the calculation of weights "//& + "applied to isoneutral slopes. There was an erroneous k-indexing "//& + "for layer thicknesses. In addition, masking at coastlines was not "//& + "used which introduced potential restart issues. This flag will be "//& "deprecated in a future release.", default=.false.) if (CS%interpolate_Res_fn) then if (CS%Res_coef_visc /= CS%Res_coef_khth) call MOM_error(FATAL, & @@ -932,12 +944,13 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.") endif + !### Change the default of GILL_EQUATORIAL_LD to True. call get_param(param_file, mdl, "GILL_EQUATORIAL_LD", Gill_equatorial_Ld, & - "If true, uses Gill's definition of the baroclinic\n"//& - "equatorial deformation radius, otherwise, if false, use\n"//& - "Pedlosky's definition. These definitions differ by a factor\n"//& - "of 2 infront of the beta term in the denominator. Gill's"//& - "is the more appropriate definition.\n", default=.false.) + "If true, uses Gill's definition of the baroclinic "//& + "equatorial deformation radius, otherwise, if false, use "//& + "Pedlosky's definition. These definitions differ by a factor "//& + "of 2 in front of the beta term in the denominator. Gill's "//& + "is the more appropriate definition.", default=.false.) if (Gill_equatorial_Ld) then oneOrTwo = 2.0 else @@ -946,8 +959,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) do J=js-1,Jeq ; do I=is-1,Ieq CS%f2_dx2_q(I,J) = (G%dxBu(I,J)**2 + G%dyBu(I,J)**2) * & - max(G%CoriolisBu(I,J)**2, absurdly_small_freq2) - CS%beta_dx2_q(I,J) = oneOrTwo * (G%dxBu(I,J)**2 + G%dyBu(I,J)**2) * (sqrt(0.5 * & + max(US%s_to_T**2 * G%CoriolisBu(I,J)**2, absurdly_small_freq2) + CS%beta_dx2_q(I,J) = oneOrTwo * (G%dxBu(I,J)**2 + G%dyBu(I,J)**2) * (US%s_to_T * sqrt(0.5 * & ( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & ((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + & (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & @@ -956,8 +969,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) do j=js,je ; do I=is-1,Ieq CS%f2_dx2_u(I,j) = (G%dxCu(I,j)**2 + G%dyCu(I,j)**2) * & - max(0.5*(G%CoriolisBu(I,J)**2+G%CoriolisBu(I,J-1)**2), absurdly_small_freq2) - CS%beta_dx2_u(I,j) = oneOrTwo * (G%dxCu(I,j)**2 + G%dyCu(I,j)**2) * (sqrt( & + max(0.5*US%s_to_T**2 * (G%CoriolisBu(I,J)**2+G%CoriolisBu(I,J-1)**2), absurdly_small_freq2) + CS%beta_dx2_u(I,j) = oneOrTwo * (G%dxCu(I,j)**2 + G%dyCu(I,j)**2) * (US%s_to_T * sqrt( & 0.25*( (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2 + & ((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + & (((G%CoriolisBu(I+1,J-1)-G%CoriolisBu(I,J-1)) * G%IdxCv(i+1,J-1))**2 + & @@ -967,8 +980,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) do J=js-1,Jeq ; do i=is,ie CS%f2_dx2_v(i,J) = (G%dxCv(i,J)**2 + G%dyCv(i,J)**2) * & - max(0.5*(G%CoriolisBu(I,J)**2+G%CoriolisBu(I-1,J)**2), absurdly_small_freq2) - CS%beta_dx2_v(i,J) = oneOrTwo * (G%dxCv(i,J)**2 + G%dyCv(i,J)**2) * (sqrt( & + max(0.5*US%s_to_T**2 * (G%CoriolisBu(I,J)**2+G%CoriolisBu(I-1,J)**2), absurdly_small_freq2) + CS%beta_dx2_v(i,J) = oneOrTwo * (G%dxCv(i,J)**2 + G%dyCv(i,J)**2) * (US%s_to_T * sqrt( & ((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & 0.25*( (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & ((G%CoriolisBu(I-1,J+1)-G%CoriolisBu(I-1,J)) * G%IdyCu(I-1,j+1))**2) + & @@ -990,10 +1003,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%f2_dx2_h(isd:ied,jsd:jed)) ; CS%f2_dx2_h(:,:) = 0.0 do j=js-1,je+1 ; do i=is-1,ie+1 CS%f2_dx2_h(i,j) = (G%dxT(i,j)**2 + G%dyT(i,j)**2) * & - max(0.25 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + max(0.25 * US%s_to_T**2 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)), & absurdly_small_freq2) - CS%beta_dx2_h(i,j) = oneOrTwo * (G%dxT(i,j)**2 + G%dyT(i,j)**2) * (sqrt(0.5 * & + CS%beta_dx2_h(i,j) = oneOrTwo * (G%dxT(i,j)**2 + G%dyT(i,j)**2) * (US%s_to_T * sqrt(0.5 * & ( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index d2a1abb730..5507ebea16 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -357,7 +357,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var !$OMP do do j=js,je ; do I=is-1,ie u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) - absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + absf = 0.5*US%s_to_T*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & ( sqrt( 0.5 * ( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 ) ) * I_l_f ) & @@ -433,7 +433,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var !$OMP do do J=js-1,je ; do i=is,ie u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) - absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + absf = 0.5*US%s_to_T*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & ( sqrt( 0.5 * ( G%dxCv(i,J)**2 + G%dyCv(i,J)**2 ) ) * I_l_f ) & @@ -524,14 +524,14 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) if (CS%id_uml > 0) then - do J=js,je ; do i=is,ie + do J=js,je ; do i=is-1,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (PSI(0.)-PSI(-.01)) enddo ; enddo call post_data(CS%id_uml, uDml_diag, CS%diag) endif if (CS%id_vml > 0) then - do J=js,je ; do i=is,ie + do J=js-1,je ; do i=is,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (PSI(0.)-PSI(-.01)) enddo ; enddo @@ -650,54 +650,50 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! U - Component !$OMP do - do j=js,je - do i=is,ie ; utimescale_diag(i,j) = 0.0 ; enddo - do i=is,ie ; vtimescale_diag(i,j) = 0.0 ; enddo - do I=is-1,ie - h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z - - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) - absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - ! peak ML visc: u_star * 0.41 * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) - ! momentum mixing rate: pi^2*visc/h_ml^2 - ! 0.41 is the von Karmen constant, 9.8696 = pi^2. - mom_mixrate = (0.41*9.8696)*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) - timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) - - timescale = timescale * CS%ml_restrat_coef -! timescale = timescale*(2?)*(L_def/L_MLI)*min(EKE/MKE,1.0 + G%dyCv(i,j)**2/L_def**2)) + do j=js,je; do I=is-1,ie + h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z - utimescale_diag(I,j) = timescale - - uDml(I) = timescale * G%mask2dCu(I,j)*G%dyCu(I,j)* & - G%IdxCu(I,j)*(Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) - - if (uDml(i) == 0) then - do k=1,nkml ; uhml(I,j,k) = 0.0 ; enddo - else - I2htot = 1.0 / (htot(i,j) + htot(i+1,j) + h_neglect) - z_topx2 = 0.0 - ! a(k) relates the sublayer transport to uDml with a linear profile. - ! The sum of a(k) through the mixed layers must be 0. - do k=1,nkml - hx2 = (h(i,j,k) + h(i+1,j,k) + h_neglect) - a(k) = (hx2 * I2htot) * (2.0 - 4.0*(z_topx2+0.5*hx2)*I2htot) - z_topx2 = z_topx2 + hx2 - if (a(k)*uDml(I) > 0.0) then - if (a(k)*uDml(I) > h_avail(i,j,k)) uDml(I) = h_avail(i,j,k) / a(k) - else - if (-a(k)*uDml(I) > h_avail(i+1,j,k)) uDml(I) = -h_avail(i+1,j,k)/a(k) - endif - enddo - do k=1,nkml - uhml(I,j,k) = a(k)*uDml(I) - uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt - enddo - endif - enddo - uDml_diag(is:ie,j) = uDml(is:ie) - enddo + u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) + absf = 0.5*US%s_to_T*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + ! peak ML visc: u_star * 0.41 * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + ! 0.41 is the von Karmen constant, 9.8696 = pi^2. + mom_mixrate = (0.41*9.8696)*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + + timescale = timescale * CS%ml_restrat_coef +! timescale = timescale*(2?)*(L_def/L_MLI)*min(EKE/MKE,1.0 + G%dyCv(i,j)**2/L_def**2)) + + uDml(I) = timescale * G%mask2dCu(I,j)*G%dyCu(I,j)* & + G%IdxCu(I,j)*(Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) + + if (uDml(I) == 0) then + do k=1,nkml ; uhml(I,j,k) = 0.0 ; enddo + else + I2htot = 1.0 / (htot(i,j) + htot(i+1,j) + h_neglect) + z_topx2 = 0.0 + ! a(k) relates the sublayer transport to uDml with a linear profile. + ! The sum of a(k) through the mixed layers must be 0. + do k=1,nkml + hx2 = (h(i,j,k) + h(i+1,j,k) + h_neglect) + a(k) = (hx2 * I2htot) * (2.0 - 4.0*(z_topx2+0.5*hx2)*I2htot) + z_topx2 = z_topx2 + hx2 + if (a(k)*uDml(I) > 0.0) then + if (a(k)*uDml(I) > h_avail(i,j,k)) uDml(I) = h_avail(i,j,k) / a(k) + else + if (-a(k)*uDml(I) > h_avail(i+1,j,k)) uDml(I) = -h_avail(i+1,j,k)/a(k) + endif + enddo + do k=1,nkml + uhml(I,j,k) = a(k)*uDml(I) + uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt + enddo + endif + + uDml_diag(I,j) = uDml(I) + utimescale_diag(I,j) = timescale + enddo; enddo ! V- component !$OMP do @@ -705,7 +701,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) - absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + absf = 0.5*US%s_to_T*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! peak ML visc: u_star * 0.41 * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 ! 0.41 is the von Karmen constant, 9.8696 = pi^2. @@ -716,8 +712,6 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI)*min(EKE/MKE,1.0 + G%dyCv(i,j)**2/L_def**2)) - vtimescale_diag(i,J) = timescale - vDml(i) = timescale * G%mask2dCv(i,J)*G%dxCv(i,J)* & G%IdyCv(i,J)*(Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) if (vDml(i) == 0) then @@ -742,9 +736,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k)*dt enddo endif - enddo - vDml_diag(is:ie,j) = vDml(is:ie) - enddo + + vtimescale_diag(i,J) = timescale + vDml_diag(i,J) = vDml(i) + enddo; enddo !$OMP do do j=js,je ; do k=1,nkml ; do i=is,ie @@ -802,9 +797,9 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & - "If true, a density-gradient dependent re-stratifying \n"//& - "flow is imposed in the mixed layer. Can be used in ALE mode\n"//& - "without restriction but in layer mode can only be used if\n"//& + "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.", default=.false.) if (.not. mixedlayer_restrat_init) return @@ -822,53 +817,53 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF", CS%ml_restrat_coef, & - "A nondimensional coefficient that is proportional to \n"//& - "the ratio of the deformation radius to the dominant \n"//& - "lengthscale of the submesoscale mixed layer \n"//& - "instabilities, times the minimum of the ratio of the \n"//& - "mesoscale eddy kinetic energy to the large-scale \n"//& - "geostrophic kinetic energy or 1 plus the square of the \n"//& - "grid spacing over the deformation radius, as detailed \n"//& + "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)", units="nondim", default=0.0) ! We use GV%nkml to distinguish between the old and new implementation of MLE. ! The old implementation only works for the layer model with nkml>0. if (GV%nkml==0) then call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF2", CS%ml_restrat_coef2, & - "As for FOX_KEMPER_ML_RESTRAT_COEF but used in a second application\n"//& + "As for FOX_KEMPER_ML_RESTRAT_COEF but used in a second application "//& "of the MLE restratification parameterization.", units="nondim", default=0.0) call get_param(param_file, mdl, "MLE_FRONT_LENGTH", CS%front_length, & - "If non-zero, is the frontal-length scale used to calculate the\n"//& - "upscaling of buoyancy gradients that is otherwise represented\n"//& - "by the parameter FOX_KEMPER_ML_RESTRAT_COEF. If MLE_FRONT_LENGTH is\n"//& + "If non-zero, is the frontal-length scale used to calculate the "//& + "upscaling of buoyancy gradients that is otherwise represented "//& + "by the parameter FOX_KEMPER_ML_RESTRAT_COEF. If MLE_FRONT_LENGTH is "//& "non-zero, it is recommended to set FOX_KEMPER_ML_RESTRAT_COEF=1.0.",& units="m", default=0.0) call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & - "If true, the MLE parameterization will use the mixed-layer\n"//& - "depth provided by the active PBL parameterization. If false,\n"//& - "MLE will estimate a MLD based on a density difference with the\n"//& + "If true, the MLE parameterization will use the mixed-layer "//& + "depth provided by the active PBL parameterization. If false, "//& + "MLE will estimate a MLD based on a density difference with the "//& "surface using the parameter MLE_DENSITY_DIFF.", default=.false.) call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & - "The time-scale for a running-mean filter applied to the mixed-layer\n"//& - "depth used in the MLE restratification parameterization. When\n"//& - "the MLD deepens below the current running-mean the running-mean\n"//& + "The time-scale for a running-mean filter applied to the mixed-layer "//& + "depth used in the MLE restratification parameterization. When "//& + "the MLD deepens below the current running-mean the running-mean "//& "is instantaneously set to the current MLD.", units="s", default=0.) call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & - "The time-scale for a running-mean filter applied to the filtered\n"//& - "mixed-layer depth used in a second MLE restratification parameterization.\n"//& - "When the MLD deepens below the current running-mean the running-mean\n"//& + "The time-scale for a running-mean filter applied to the filtered "//& + "mixed-layer depth used in a second MLE restratification parameterization. "//& + "When the MLD deepens below the current running-mean the running-mean "//& "is instantaneously set to the current MLD.", units="s", default=0.) if (.not. CS%MLE_use_PBL_MLD) then call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & - "Density difference used to detect the mixed-layer\n"//& - "depth used for the mixed-layer eddy parameterization\n"//& + "Density difference used to detect the mixed-layer "//& + "depth used for the mixed-layer eddy parameterization "//& "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03) endif call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & - "Fraction by which to extend the mixed-layer restratification\n"//& - "depth used for a smoother stream function at the base of\n"//& + "Fraction by which to extend the mixed-layer restratification "//& + "depth used for a smoother stream function at the base of "//& "the mixed-layer.", units="nondim", default=0.0) call get_param(param_file, mdl, "MLE_MLD_STRETCH", CS%MLE_MLD_stretch, & - "A scaling coefficient for stretching/shrinking the MLD\n"//& + "A scaling coefficient for stretching/shrinking the MLD "//& "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) call get_param(param_file, mdl, "MLE_USE_MLD_AVE_BUG", CS%MLE_use_MLD_ave_bug, & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 802e26a404..4d75494b72 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1621,8 +1621,8 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa, dt, T_f, S_f, G, GV, halo_here) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_in !< Input temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_in !< Input salinity [ppt] - real, intent(in) :: kappa !< Constant diffusivity to use [Z2 s-1 ~> m2 s-1] - real, intent(in) :: dt !< Time increment [s] + real, intent(in) :: kappa !< Constant diffusivity to use [Z2 T-1 ~> m2 s-1] + real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T_f !< Filled temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S_f !< Filled salinity [ppt] integer, optional, intent(in) :: halo_here !< Number of halo points to work on, @@ -1718,13 +1718,13 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "THICKNESSDIFFUSE", CS%thickness_diffuse, & - "If true, interface heights are diffused with a \n"//& + "If true, interface heights are diffused with a "//& "coefficient of KHTH.", default=.false.) call get_param(param_file, mdl, "KHTH", CS%Khth, & "The background horizontal thickness diffusivity.", & units = "m2 s-1", default=0.0) call get_param(param_file, mdl, "KHTH_SLOPE_CFF", CS%KHTH_Slope_Cff, & - "The nondimensional coefficient in the Visbeck formula \n"//& + "The nondimensional coefficient in the Visbeck formula "//& "for the interface depth diffusivity", units="nondim", & default=0.0) call get_param(param_file, mdl, "KHTH_MIN", CS%KHTH_Min, & @@ -1734,45 +1734,45 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "The maximum horizontal thickness diffusivity.", & units = "m2 s-1", default=0.0) call get_param(param_file, mdl, "KHTH_MAX_CFL", CS%max_Khth_CFL, & - "The maximum value of the local diffusive CFL ratio that \n"//& - "is permitted for the thickness diffusivity. 1.0 is the \n"//& - "marginally unstable value in a pure layered model, but \n"//& - "much smaller numbers (e.g. 0.1) seem to work better for \n"//& + "The maximum value of the local diffusive CFL ratio that "//& + "is permitted for the thickness diffusivity. 1.0 is the "//& + "marginally unstable value in a pure layered model, but "//& + "much smaller numbers (e.g. 0.1) seem to work better for "//& "ALE-based models.", units = "nondimensional", default=0.8) if (CS%max_Khth_CFL < 0.0) CS%max_Khth_CFL = 0.0 call get_param(param_file, mdl, "DETANGLE_INTERFACES", CS%detangle_interfaces, & - "If defined add 3-d structured enhanced interface height \n"//& - "diffusivities to horizonally smooth jagged layers.", & + "If defined add 3-d structured enhanced interface height "//& + "diffusivities to horizontally smooth jagged layers.", & default=.false.) CS%detangle_time = 0.0 if (CS%detangle_interfaces) & call get_param(param_file, mdl, "DETANGLE_TIMESCALE", CS%detangle_time, & - "A timescale over which maximally jagged grid-scale \n"//& - "thickness variations are suppressed. This must be \n"//& + "A timescale over which maximally jagged grid-scale "//& + "thickness variations are suppressed. This must be "//& "longer than DT, or 0 to use DT.", units = "s", default=0.0) call get_param(param_file, mdl, "KHTH_SLOPE_MAX", CS%slope_max, & - "A slope beyond which the calculated isopycnal slope is \n"//& + "A slope beyond which the calculated isopycnal slope is "//& "not reliable and is scaled away.", units="nondim", default=0.01) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & - "A diapycnal diffusivity that is used to interpolate \n"//& + "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & default=1.0e-6, scale=US%m_to_Z**2) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", CS%use_FGNV_streamfn, & - "If true, use the streamfunction formulation of\n"// & - "Ferrari et al., 2010, which effectively emphasizes\n"//& + "If true, use the streamfunction formulation of "//& + "Ferrari et al., 2010, which effectively emphasizes "//& "graver vertical modes by smoothing in the vertical.", & default=.false.) call get_param(param_file, mdl, "FGNV_FILTER_SCALE", CS%FGNV_scale, & - "A coefficient scaling the vertical smoothing term in the\n"//& + "A coefficient scaling the vertical smoothing term in the "//& "Ferrari et al., 2010, streamfunction formulation.", & default=1., do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "FGNV_C_MIN", CS%FGNV_c_min, & - "A minium wave speed used in the Ferrari et al., 2010,\n"//& + "A minium wave speed used in the Ferrari et al., 2010, "//& "streamfunction formulation.", & default=0., units="m s-1", do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "FGNV_STRAT_FLOOR", strat_floor, & - "A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010,\n"//& - "streamfunction formulation, expressed as a fraction of planetary\n"//& + "A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, "//& + "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "OMEGA",omega, & diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 075c69ed65..57a1d78c03 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -123,43 +123,43 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) enddo ; enddo call get_param(param_file, mdl, "TIDE_M2", use_M2, & - "If true, apply tidal momentum forcing at the M2 \n"//& + "If true, apply tidal momentum forcing at the M2 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_S2", use_S2, & - "If true, apply tidal momentum forcing at the S2 \n"//& + "If true, apply tidal momentum forcing at the S2 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_N2", use_N2, & - "If true, apply tidal momentum forcing at the N2 \n"//& + "If true, apply tidal momentum forcing at the N2 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_K2", use_K2, & - "If true, apply tidal momentum forcing at the K2 \n"//& + "If true, apply tidal momentum forcing at the K2 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_K1", use_K1, & - "If true, apply tidal momentum forcing at the K1 \n"//& + "If true, apply tidal momentum forcing at the K1 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_O1", use_O1, & - "If true, apply tidal momentum forcing at the O1 \n"//& + "If true, apply tidal momentum forcing at the O1 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_P1", use_P1, & - "If true, apply tidal momentum forcing at the P1 \n"//& + "If true, apply tidal momentum forcing at the P1 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_Q1", use_Q1, & - "If true, apply tidal momentum forcing at the Q1 \n"//& + "If true, apply tidal momentum forcing at the Q1 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_MF", use_MF, & - "If true, apply tidal momentum forcing at the MF \n"//& + "If true, apply tidal momentum forcing at the MF "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_MM", use_MM, & - "If true, apply tidal momentum forcing at the MM \n"//& + "If true, apply tidal momentum forcing at the MM "//& "frequency. This is only used if TIDES is true.", & default=.false.) @@ -179,29 +179,29 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) endif call get_param(param_file, mdl, "TIDAL_SAL_FROM_FILE", CS%tidal_sal_from_file, & - "If true, read the tidal self-attraction and loading \n"//& - "from input files, specified by TIDAL_INPUT_FILE. \n"//& + "If true, read the tidal self-attraction and loading "//& + "from input files, specified by TIDAL_INPUT_FILE. "//& "This is only used if TIDES is true.", default=.false.) call get_param(param_file, mdl, "USE_PREVIOUS_TIDES", CS%use_prev_tides, & - "If true, use the SAL from the previous iteration of the \n"//& - "tides to facilitate convergent iteration. \n"//& + "If true, use the SAL from the previous iteration of the "//& + "tides to facilitate convergent iteration. "//& "This is only used if TIDES is true.", default=.false.) call get_param(param_file, mdl, "TIDE_USE_SAL_SCALAR", CS%use_sal_scalar, & - "If true and TIDES is true, use the scalar approximation \n"//& + "If true and TIDES is true, use the scalar approximation "//& "when calculating self-attraction and loading.", & default=.not.CS%tidal_sal_from_file) ! If it is being used, sal_scalar MUST be specified in param_file. if (CS%use_sal_scalar .or. CS%use_prev_tides) & call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & - "The constant of proportionality between sea surface \n"//& - "height (really it should be bottom pressure) anomalies \n"//& - "and bottom geopotential anomalies. This is only used if \n"//& + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & fail_if_missing=.true.) if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & - &"to accomodate all the registered tidal constituents.")') nc + &"to accommodate all the registered tidal constituents.")') nc call MOM_error(FATAL, "MOM_tidal_forcing"//mesg) endif @@ -290,15 +290,15 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) ! values that are actually used. do c=1,nc call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_FREQ", CS%freq(c), & - "Frequency of the "//trim(CS%const_name(c))//" tidal constituent. \n"//& + "Frequency of the "//trim(CS%const_name(c))//" tidal constituent. "//& "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & " are true.", units="s-1", default=freq_def(c)) call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_AMP", CS%amp(c), & - "Amplitude of the "//trim(CS%const_name(c))//" tidal constituent. \n"//& + "Amplitude of the "//trim(CS%const_name(c))//" tidal constituent. "//& "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & " are true.", units="m", default=amp_def(c)) call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_PHASE_T0", CS%phase0(c), & - "Phase of the "//trim(CS%const_name(c))//" tidal constituent at time 0. \n"//& + "Phase of the "//trim(CS%const_name(c))//" tidal constituent at time 0. "//& "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & " are true.", units="radians", default=phase0_def(c)) enddo diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 7678a4b799..0cc63a8fc0 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -170,8 +170,8 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SPONGE", use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) if (.not.use_sponge) return @@ -183,14 +183,14 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ default=.false.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used \n"//& + "This sets the reconstruction scheme used "//& " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction \n"//& - "scheme is used within boundary cells rather \n"// & - "than PCM. E.g., if PPM is used for remapping, a \n" //& + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) @@ -401,8 +401,8 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SPONGE", use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) if (.not.use_sponge) return @@ -414,14 +414,14 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) default=.false.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used \n"//& + "This sets the reconstruction scheme used "//& " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction \n"//& - "scheme is used within boundary cells rather \n"// & - "than PCM. E.g., if PPM is used for remapping, a \n" //& + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index ef0e9504ac..0eeef2203b 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -201,7 +201,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) call log_version(paramFile, mdl, version, 'This is the MOM wrapper to CVMix:KPP\n' // & 'See http://cvmix.github.io/') call get_param(paramFile, mdl, "USE_KPP", KPP_init, & - "If true, turns on the [CVMix] KPP scheme of Large et al., 1994,\n"// & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "// & "to calculate diffusivities and non-local transport in the OBL.", & default=.false.) ! Forego remainder of initialization if not using this scheme @@ -216,22 +216,22 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) if (present(passive)) passive=CS%passiveMode ! This is passed back to the caller so ! the caller knows to not use KPP output call get_param(paramFile, mdl, 'APPLY_NONLOCAL_TRANSPORT', CS%applyNonLocalTrans, & - 'If True, applies the non-local transport to heat and scalars.\n'// & - 'If False, calculates the non-local transport and tendencies but\n'//& + 'If True, applies the non-local transport to heat and scalars. '// & + 'If False, calculates the non-local transport and tendencies but '//& 'purely for diagnostic purposes.', & default=.not. CS%passiveMode) call get_param(paramFile, mdl, 'N_SMOOTH', CS%n_smooth, & - 'The number of times the 1-1-4-1-1 Laplacian filter is applied on\n'// & + 'The number of times the 1-1-4-1-1 Laplacian filter is applied on '// & 'OBL depth.', & default=0) if (CS%n_smooth > 0) then call get_param(paramFile, mdl, 'DEEPEN_ONLY_VIA_SMOOTHING', CS%deepen_only, & - 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth.\n'// & + 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth '// & 'gets deeper via smoothing.', & default=.false.) endif call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & - 'Critical bulk Richardson number used to define depth of the\n'// & + 'Critical bulk Richardson number used to define depth of the '// & 'surface Ocean Boundary Layer (OBL).', & units='nondim', default=0.3) call get_param(paramFile, mdl, 'VON_KARMAN', CS%vonKarman, & @@ -252,7 +252,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'If True, limit OBL depth to be no deeper than Ekman depth.', & default=.False.) call get_param(paramFile, mdl, 'COMPUTE_MONIN_OBUKHOV', CS%computeMoninObukhov, & - 'If True, limit the OBL depth to be no deeper than\n'// & + 'If True, limit the OBL depth to be no deeper than '// & 'Monin-Obukhov depth.', & default=.False.) call get_param(paramFile, mdl, 'CS', CS%cs, & @@ -262,47 +262,47 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'Parameter for computing non-local term.', & units='nondim', default=6.32739901508) call get_param(paramFile, mdl, 'DEEP_OBL_OFFSET', CS%deepOBLoffset, & - 'If non-zero, the distance above the bottom to which the OBL is clipped\n'// & + 'If non-zero, the distance above the bottom to which the OBL is clipped '// & 'if it would otherwise reach the bottom. The smaller of this and 0.1D is used.', & units='m',default=0.) call get_param(paramFile, mdl, 'FIXED_OBLDEPTH', CS%fixedOBLdepth, & - 'If True, fix the OBL depth to FIXED_OBLDEPTH_VALUE\n'// & - 'rather than using the OBL depth from CVMix.\n'// & + 'If True, fix the OBL depth to FIXED_OBLDEPTH_VALUE '// & + 'rather than using the OBL depth from CVMix. '// & 'This option is just for testing purposes.', & default=.False.) call get_param(paramFile, mdl, 'FIXED_OBLDEPTH_VALUE', CS%fixedOBLdepth_value, & - 'Value for the fixed OBL depth when fixedOBLdepth==True. \n'// & - 'This parameter is for just for testing purposes. \n'// & + 'Value for the fixed OBL depth when fixedOBLdepth==True. '// & + 'This parameter is for just for testing purposes. '// & 'It will over-ride the OBLdepth computed from CVMix.', & units='m',default=30.0) call get_param(paramFile, mdl, 'SURF_LAYER_EXTENT', CS%surf_layer_ext, & 'Fraction of OBL depth considered in the surface layer.', & units='nondim',default=0.10) call get_param(paramFile, mdl, 'MINIMUM_OBL_DEPTH', CS%minOBLdepth, & - 'If non-zero, a minimum depth to use for KPP OBL depth. Independent of\n'// & + 'If non-zero, a minimum depth to use for KPP OBL depth. Independent of '// & 'this parameter, the OBL depth is always at least as deep as the first layer.', & units='m',default=0.) call get_param(paramFile, mdl, 'MINIMUM_VT2', CS%minVtsqr, & - 'Min of the unresolved velocity Vt2 used in Rib CVMix calculation. \n'// & + 'Min of the unresolved velocity Vt2 used in Rib CVMix calculation.\n'// & 'Scaling: MINIMUM_VT2 = const1*d*N*ws, with d=1m, N=1e-5/s, ws=1e-6 m/s.', & units='m2/s2',default=1e-10) ! smg: for removal below call get_param(paramFile, mdl, 'CORRECT_SURFACE_LAYER_AVERAGE', CS%correctSurfLayerAvg, & - 'If true, applies a correction step to the averaging of surface layer\n'// & + 'If true, applies a correction step to the averaging of surface layer '// & 'properties. This option is obsolete.', default=.False.) if (CS%correctSurfLayerAvg) & call MOM_error(FATAL,'Correct surface layer average disabled in code. To recover \n'// & ' feature will require code intervention.') call get_param(paramFile, mdl, 'FIRST_GUESS_SURFACE_LAYER_DEPTH', CS%surfLayerDepth, & - 'The first guess at the depth of the surface layer used for averaging\n'// & - 'the surface layer properties. If =0, the top model level properties\n'// & - 'will be used for the surface layer. If CORRECT_SURFACE_LAYER_AVERAGE=True, a\n'// & + 'The first guess at the depth of the surface layer used for averaging '// & + 'the surface layer properties. If =0, the top model level properties '// & + 'will be used for the surface layer. If CORRECT_SURFACE_LAYER_AVERAGE=True, a '// & 'subsequent correction is applied. This parameter is obsolete', units='m', default=0.) ! smg: for removal above call get_param(paramFile, mdl, 'NLT_SHAPE', string, & - 'MOM6 method to set nonlocal transport profile.\n'// & + 'MOM6 method to set nonlocal transport profile. '// & 'Over-rides the result from CVMix. Allowed values are: \n'// & '\t CVMix - Uses the profiles from CVMix specified by MATCH_TECHNIQUE\n'//& '\t LINEAR - A linear profile, 1-sigma\n'// & @@ -320,7 +320,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) "Unrecognized NLT_SHAPE option"//trim(string)) end select call get_param(paramFile, mdl, 'MATCH_TECHNIQUE', CS%MatchTechnique, & - 'CVMix method to set profile function for diffusivity and NLT,\n'// & + 'CVMix method to set profile function for diffusivity and NLT, '// & 'as well as matching across OBL base. Allowed values are: \n'// & '\t SimpleShapes = sigma*(1-sigma)^2 for both diffusivity and NLT\n'// & '\t MatchGradient = sigma*(1-sigma)^2 for NLT; diffusivity profile from matching\n'//& @@ -328,19 +328,19 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) '\t ParabolicNonLocal = sigma*(1-sigma)^2 for diffusivity; (1-sigma)^2 for NLT', & default='SimpleShapes') if (CS%MatchTechnique == 'ParabolicNonLocal') then - ! This forces Cs2 (Cs in non-local computation) to equal 1 for parabolic non-local option. - ! May be used during CVMix initialization. - Cs_is_one=.true. + ! This forces Cs2 (Cs in non-local computation) to equal 1 for parabolic non-local option. + ! May be used during CVMix initialization. + Cs_is_one=.true. endif if (CS%MatchTechnique == 'ParabolicNonLocal' .or. CS%MatchTechnique == 'SimpleShapes') then - ! if gradient won't be matched, lnoDGat1=.true. - lnoDGat1=.true. + ! if gradient won't be matched, lnoDGat1=.true. + lnoDGat1=.true. endif ! safety check to avoid negative diff/visc if (CS%MatchTechnique == 'MatchBoth' .and. (CS%interpType2 == 'cubic' .or. & - CS%interpType2 == 'quadratic')) then - call MOM_error(FATAL,"If MATCH_TECHNIQUE=MatchBoth, INTERP_TYPE2 must be set to \n"//& + CS%interpType2 == 'quadratic')) then + call MOM_error(FATAL,"If MATCH_TECHNIQUE=MatchBoth, INTERP_TYPE2 must be set to \n"//& "linear or LMD94 (recommended) to avoid negative viscosity and diffusivity.\n"//& "Please select one of these valid options." ) endif @@ -349,15 +349,15 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'If True, zeroes the KPP diffusivity and viscosity; for testing purpose.',& default=.False.) call get_param(paramFile, mdl, 'KPP_IS_ADDITIVE', CS%KPPisAdditive, & - 'If true, adds KPP diffusivity to diffusivity from other schemes.'//& + 'If true, adds KPP diffusivity to diffusivity from other schemes.\n'//& 'If false, KPP is the only diffusivity wherever KPP is non-zero.', & default=.True.) call get_param(paramFile, mdl, 'KPP_SHORTWAVE_METHOD',string, & 'Determines contribution of shortwave radiation to KPP surface '// & 'buoyancy flux. Options include:\n'// & ' ALL_SW: use total shortwave radiation\n'// & - ' MXL_SW: use shortwave radiation absorbed by mixing layer\n'// & - ' LV1_SW: use shortwave radiation absorbed by top model layer', & + ' MXL_SW: use shortwave radiation absorbed by mixing layer\n'// & + ' LV1_SW: use shortwave radiation absorbed by top model layer', & default='MXL_SW') select case ( trim(string) ) case ("ALL_SW") ; CS%SW_METHOD = SW_METHOD_ALL_SW @@ -367,7 +367,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) "Unrecognized KPP_SHORTWAVE_METHOD option"//trim(string)) end select call get_param(paramFile, mdl, 'CVMix_ZERO_H_WORK_AROUND', CS%min_thickness, & - 'A minimum thickness used to avoid division by small numbers in the vicinity\n'// & + 'A minimum thickness used to avoid division by small numbers in the vicinity '// & 'of vanished layers. This is independent of MIN_THICKNESS used in other parts of MOM.', & units='m', default=0.) @@ -381,7 +381,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'mixing coefficient.', units="", Default=.false.) if (CS%LT_K_Enhancement) then call get_param(paramFile, mdl, 'KPP_LT_K_SHAPE', string, & - 'Vertical dependence of LT enhancement of mixing. \n'// & + 'Vertical dependence of LT enhancement of mixing. '// & 'Valid options are: \n'// & '\t CONSTANT = Constant value for full OBL\n'// & '\t SCALED = Varies based on normalized shape function.', & @@ -393,7 +393,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) "Unrecognized KPP_LT_K_SHAPE option: "//trim(string)) end select call get_param(paramFile, mdl, "KPP_LT_K_METHOD", string , & - 'Method to enhance mixing coefficient in KPP. \n'// & + 'Method to enhance mixing coefficient in KPP. '// & 'Valid options are: \n'// & '\t CONSTANT = Constant value (KPP_K_ENH_FAC) \n'// & '\t VR12 = Function of Langmuir number based on VR12\n'// & @@ -418,7 +418,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'in Bulk Richardson Number.', units="", Default=.false.) if (CS%LT_Vt2_Enhancement) then call get_param(paramFile, mdl, "KPP_LT_VT2_METHOD",string , & - 'Method to enhance Vt2 in KPP. \n'// & + 'Method to enhance Vt2 in KPP. '// & 'Valid options are: \n'// & '\t CONSTANT = Constant value (KPP_VT2_ENH_FAC) \n'// & '\t VR12 = Function of Langmuir number based on VR12\n'// & @@ -959,8 +959,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF enddo ! things independent of position within the column - Coriolis = 0.25*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) & - +(G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) + Coriolis = 0.25*US%s_to_T*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) + & + (G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) surfFricVel = US%Z_to_m * uStar(i,j) ! Bullk Richardson number computed for each cell in a column, diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 19327cd007..1a9cb890ef 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -79,9 +79,9 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, & "Parameterization of enhanced mixing due to convection via CVMix") call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, & - "If true, turns on the enhanced mixing due to convection \n"// & - "via CVMix. This scheme increases diapycnal diffs./viscs. \n"// & - " at statically unstable interfaces. Relevant parameters are \n"// & + "If true, turns on the enhanced mixing due to convection "//& + "via CVMix. This scheme increases diapycnal diffs./viscs. "//& + "at statically unstable interfaces. Relevant parameters are "//& "contained in the CVMix_CONVECTION% parameter block.", & default=.false.) @@ -105,17 +105,17 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) call openParameterBlock(param_file,'CVMix_CONVECTION') call get_param(param_file, mdl, "PRANDTL_CONV", prandtl_conv, & - "The turbulent Prandtl number applied to convective \n"//& + "The turbulent Prandtl number applied to convective "//& "instabilities (i.e., used to convert KD_CONV into KV_CONV)", & units="nondim", default=1.0) call get_param(param_file, mdl, 'KD_CONV', CS%kd_conv_const, & - "Diffusivity used in convective regime. Corresponding viscosity \n" // & + "Diffusivity used in convective regime. Corresponding viscosity "//& "(KV_CONV) will be set to KD_CONV * PRANDTL_TURB.", & units='m2/s', default=1.00) call get_param(param_file, mdl, 'BV_SQR_CONV', CS%bv_sqr_conv, & - "Threshold for squared buoyancy frequency needed to trigger \n" // & + "Threshold for squared buoyancy frequency needed to trigger "//& "Brunt-Vaisala parameterization.", & units='1/s^2', default=0.0) diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 0e80f166c5..4f535197a7 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -82,9 +82,9 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, & "Parameterization of mixing due to double diffusion processes via CVMix") call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, & - "If true, turns on double diffusive processes via CVMix. \n"// & - "Note that double diffusive processes on viscosity are ignored \n"// & - "in CVMix, see http://cvmix.github.io/ for justification.",& + "If true, turns on double diffusive processes via CVMix. "//& + "Note that double diffusive processes on viscosity are ignored "//& + "in CVMix, see http://cvmix.github.io/ for justification.", & default=.false.) if (.not. CVMix_ddiff_init) return @@ -100,7 +100,7 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) units="nondim", default=2.55) call get_param(param_file, mdl, "KAPPA_DDIFF_S", CS%kappa_ddiff_s, & - "Leading coefficient in formula for salt-fingering regime \n"// & + "Leading coefficient in formula for salt-fingering regime "//& "for salinity diffusion.", units="m2 s-1", default=1.0e-4) call get_param(param_file, mdl, "DDIFF_EXP1", CS%ddiff_exp1, & diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 06fa74bdc7..9e0f6ca708 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -213,14 +213,14 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, & "Parameterization of shear-driven turbulence via CVMix (various options)") call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, & - "If true, use the Large-McWilliams-Doney (JGR 1994) \n"//& + "If true, use the Large-McWilliams-Doney (JGR 1994) "//& "shear mixing parameterization.", default=.false.) if (CS%use_LMD94) then NumberTrue=NumberTrue + 1 CS%Mix_Scheme='KPP' endif call get_param(param_file, mdl, "USE_PP81", CS%use_PP81, & - "If true, use the Pacanowski and Philander (JPO 1981) \n"//& + "If true, use the Pacanowski and Philander (JPO 1981) "//& "shear mixing parameterization.", default=.false.) if (CS%use_PP81) then NumberTrue = NumberTrue + 1 @@ -243,16 +243,16 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) "Leading coefficient in KPP shear mixing.", & units="nondim", default=5.e-3) call get_param(param_file, mdl, "RI_ZERO", CS%Ri_Zero, & - "Critical Richardson for KPP shear mixing,"// & - " NOTE this the internal mixing and this is"// & - " not for setting the boundary layer depth." & + "Critical Richardson for KPP shear mixing, "// & + "NOTE this the internal mixing and this is "// & + "not for setting the boundary layer depth." & ,units="nondim", default=0.8) call get_param(param_file, mdl, "KPP_EXP", CS%KPP_exp, & - "Exponent of unitless factor of diffusivities,"// & - " for KPP internal shear mixing scheme." & + "Exponent of unitless factor of diffusivities, "// & + "for KPP internal shear mixing scheme." & ,units="nondim", default=3.0) call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & - "If true, vertically smooth the Richardson"// & + "If true, vertically smooth the Richardson "// & "number by applying a 1-2-1 filter once.", & default = .false.) call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 7d683944a2..e941ec3eea 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -48,7 +48,7 @@ module MOM_bkgnd_mixing !! Bryan-Lewis profile [m] real :: bckgrnd_vdc1 !< Background diffusivity (Ledwell) when !! horiz_varying_background=.true. - real :: bckgrnd_vdc_eq !! Equatorial diffusivity (Gregg) when + real :: bckgrnd_vdc_eq !< Equatorial diffusivity (Gregg) when !! horiz_varying_background=.true. real :: bckgrnd_vdc_psim !< Max. PSI induced diffusivity (MacKinnon) when !! horiz_varying_background=.true. @@ -144,12 +144,12 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) "Adding static vertical background mixing coefficients") call get_param(param_file, mdl, "KD", CS%Kd, & - "The background diapycnal diffusivity of density in the \n"//& - "interior. Zero or the molecular value, ~1e-7 m2 s-1, \n"//& + "The background diapycnal diffusivity of density in the "//& + "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& "may be used.", units="m2 s-1", scale=US%m_to_Z**2, fail_if_missing=.true.) call get_param(param_file, mdl, "KV", Kv, & - "The background kinematic viscosity in the interior. \n"//& + "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true.) @@ -172,13 +172,13 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) ! cannot be a NaN. else call get_param(param_file, mdl, "KDML", CS%Kdml, & - "If BULKMIXEDLAYER is false, KDML is the elevated \n"//& - "diapycnal diffusivity in the topmost HMIX of fluid. \n"//& + "If BULKMIXEDLAYER is false, KDML is the elevated "//& + "diapycnal diffusivity in the topmost HMIX of fluid. "//& "KDML is only used if BULKMIXEDLAYER is false.", & units="m2 s-1", default=CS%Kd*US%Z_to_m**2, scale=US%m_to_Z**2) call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & - "The prescribed depth over which the near-surface \n"//& - "viscosity and diffusivity are elevated when the bulk \n"//& + "The prescribed depth over which the near-surface "//& + "viscosity and diffusivity are elevated when the bulk "//& "mixed layer is not used.", units="m", scale=US%m_to_Z, fail_if_missing=.true.) endif @@ -186,10 +186,9 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) ! call openParameterBlock(param_file,'MOM_BACKGROUND_MIXING') - call get_param(param_file, mdl, "BRYAN_LEWIS_DIFFUSIVITY", & - CS%Bryan_Lewis_diffusivity, & - "If true, use a Bryan & Lewis (JGR 1979) like tanh \n"//& - "profile of background diapycnal diffusivity with depth. \n"//& + call get_param(param_file, mdl, "BRYAN_LEWIS_DIFFUSIVITY", CS%Bryan_Lewis_diffusivity, & + "If true, use a Bryan & Lewis (JGR 1979) like tanh "//& + "profile of background diapycnal diffusivity with depth. "//& "This is done via CVMix.", default=.false.) if (CS%Bryan_Lewis_diffusivity) then @@ -219,7 +218,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "HORIZ_VARYING_BACKGROUND", & CS%horiz_varying_background, & - "If true, apply vertically uniform, latitude-dependent background\n"//& + "If true, apply vertically uniform, latitude-dependent background "//& "diffusivity, as described in Danabasoglu et al., 2012", & default=.false.) @@ -248,7 +247,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) endif call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & - "Turbulent Prandtl number used to convert vertical \n"//& + "Turbulent Prandtl number used to convert vertical "//& "background diffusivities into viscosities.", & units="nondim", default=1.0) @@ -265,18 +264,16 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) endif - call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND", & - CS%Henyey_IGW_background, & - "If true, use a latitude-dependent scaling for the near \n"//& - "surface background diffusivity, as described in \n"//& + call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND", CS%Henyey_IGW_background, & + "If true, use a latitude-dependent scaling for the near "//& + "surface background diffusivity, as described in "//& "Harrison & Hallberg, JPO 2008.", default=.false.) if (CS%Henyey_IGW_background) call check_bkgnd_scheme(CS, "HENYEY_IGW_BACKGROUND") - call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND_NEW", & - CS%Henyey_IGW_background_new, & - "If true, use a better latitude-dependent scaling for the\n"//& - "background diffusivity, as described in \n"//& + call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND_NEW", CS%Henyey_IGW_background_new, & + "If true, use a better latitude-dependent scaling for the "//& + "background diffusivity, as described in "//& "Harrison & Hallberg, JPO 2008.", default=.false.) if (CS%Henyey_IGW_background_new) call check_bkgnd_scheme(CS, "HENYEY_IGW_BACKGROUND_NEW") @@ -288,22 +285,21 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) if (CS%Henyey_IGW_background) & call get_param(param_file, mdl, "HENYEY_N0_2OMEGA", CS%N0_2Omega, & - "The ratio of the typical Buoyancy frequency to twice \n"//& - "the Earth's rotation period, used with the Henyey \n"//& + "The ratio of the typical Buoyancy frequency to twice "//& + "the Earth's rotation period, used with the Henyey "//& "scaling from the mixing.", units="nondim", default=20.0) call get_param(param_file, mdl, "KD_TANH_LAT_FN", & CS%Kd_tanh_lat_fn, & - "If true, use a tanh dependence of Kd_sfc on latitude, \n"//& - "like CM2.1/CM2M. There is no physical justification \n"//& - "for this form, and it can not be used with \n"//& + "If true, use a tanh dependence of Kd_sfc on latitude, "//& + "like CM2.1/CM2M. There is no physical justification "//& + "for this form, and it can not be used with "//& "HENYEY_IGW_BACKGROUND.", default=.false.) if (CS%Kd_tanh_lat_fn) & - call get_param(param_file, mdl, "KD_TANH_LAT_SCALE", & - CS%Kd_tanh_lat_scale, & - "A nondimensional scaling for the range ofdiffusivities \n"//& - "with KD_TANH_LAT_FN. Valid values are in the range of \n"//& + call get_param(param_file, mdl, "KD_TANH_LAT_SCALE", CS%Kd_tanh_lat_scale, & + "A nondimensional scaling for the range ofdiffusivities "//& + "with KD_TANH_LAT_FN. Valid values are in the range of "//& "-2 to 2; 0.4 reproduces CM2M.", units="nondim", default=0.0) if (CS%Henyey_IGW_background .and. CS%Kd_tanh_lat_fn) call MOM_error(FATAL, & @@ -380,7 +376,7 @@ end subroutine sfc_bkgnd_mixing !> Calculates the vertical background diffusivities/viscosities -subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) +subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. @@ -388,9 +384,9 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< squared buoyancy frequency associated - !! with layers [s-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: kd_lay !< Diapycnal diffusivity of each layer - !! [Z2 s-1 ~> m2 s-1]. + !! with layers [T-2 ~> s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd_lay !< Diapycnal diffusivity of each layer + !! [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 s-1 ~> m2 s-1] integer, intent(in) :: j !< Meridional grid index @@ -447,7 +443,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) CS%Kd_bkgnd(i,j,K) = US%m_to_Z**2*Kd_col(K) enddo do k=1,nz - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*US%m_to_Z**2*(Kd_col(K) + Kd_col(K+1)) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_col(K) + Kd_col(K+1)) enddo enddo ! i loop @@ -460,7 +456,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) if (depth_c <= CS%Hmix) then ; CS%Kd_bkgnd(i,j,k) = CS%Kdml elseif (depth_c >= 2.0*CS%Hmix) then ; CS%Kd_bkgnd(i,j,k) = CS%Kd_sfc(i,j) else - Kd_lay(i,j,k) = ((CS%Kd_sfc(i,j) - CS%Kdml) * I_Hmix) * depth_c + & + Kd_lay(i,j,k) = US%T_to_s * ((CS%Kd_sfc(i,j) - CS%Kdml) * I_Hmix) * depth_c + & (2.0*CS%Kdml - CS%Kd_sfc(i,j)) endif @@ -506,7 +502,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) CS%kv_bkgnd(i,j,:) = CS%kd_bkgnd(i,j,:) * CS%prandtl_bkgnd ! Update Kd (uniform profile; no interpolation needed) - kd_lay(i,j,:) = CS%kd_bkgnd(i,j,1) + Kd_lay(i,j,:) = US%T_to_s * CS%kd_bkgnd(i,j,1) enddo @@ -514,15 +510,15 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) I_x30 = 2.0 / invcosh(CS%N0_2Omega*2.0) ! This is evaluated at 30 deg. do k=1,nz ; do i=is,ie abs_sin = max(epsilon,abs(sin(G%geoLatT(i,j)*deg_to_rad))) - N_2Omega = max(abs_sin,sqrt(N2_lay(i,k))*I_2Omega) + N_2Omega = max(abs_sin,sqrt(US%s_to_T**2 * N2_lay(i,k))*I_2Omega) N02_N2 = (CS%N0_2Omega/N_2Omega)**2 - Kd_lay(i,j,k) = max(CS%Kd_min, CS%Kd_sfc(i,j) * & + Kd_lay(i,j,k) = US%T_to_s * max(CS%Kd_min, CS%Kd_sfc(i,j) * & ((abs_sin * invcosh(N_2Omega/abs_sin)) * I_x30)*N02_N2) enddo ; enddo else do k=1,nz ; do i=is,ie - Kd_lay(i,j,k) = CS%Kd_sfc(i,j) + Kd_lay(i,j,k) = US%T_to_s * CS%Kd_sfc(i,j) enddo ; enddo endif @@ -532,7 +528,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) CS%kd_bkgnd(i,j,1) = 0.0; CS%kv_bkgnd(i,j,1) = 0.0 CS%kd_bkgnd(i,j,nz+1) = 0.0; CS%kv_bkgnd(i,j,nz+1) = 0.0 do k=2,nz - CS%Kd_bkgnd(i,j,k) = 0.5*(Kd_lay(i,j,K-1) + Kd_lay(i,j,K)) + CS%Kd_bkgnd(i,j,k) = US%s_to_T * (0.5*(Kd_lay(i,j,K-1) + Kd_lay(i,j,K))) CS%Kv_bkgnd(i,j,k) = CS%Kd_bkgnd(i,j,k) * CS%prandtl_bkgnd enddo enddo diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 9b3aee8e7d..17b7bb5c15 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -670,7 +670,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C kU_Star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & fluxes%frac_shelf_h(i,j) * (0.41*fluxes%ustar_shelf(i,j)) endif - absf_x_H = 0.25 * US%m_to_Z * h(i,0) * & !### I think this should be H_to_Z -RWH + absf_x_H = 0.25 * US%m_to_Z * US%s_to_T * h(i,0) * & !### I think this should be H_to_Z -RWH ((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) ! If the mixed layer vertical viscosity specification is changed in @@ -1355,7 +1355,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, real :: totEn_Z ! The total potential energy released by convection, [Z3 s-2 ~> m3 s-2]. real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. - real :: absf ! The absolute value of f averaged to thickness points, s-1. + real :: absf ! The absolute value of f averaged to thickness points [s-1]. real :: U_star ! The friction velocity [Z s-1 ~> m s-1]. real :: absf_Ustar ! The absolute value of f divided by U_star [Z-1 ~> m-1]. real :: wind_TKE_src ! The surface wind source of TKE [Z m2 s-3 ~> m3 s-3]. @@ -1377,8 +1377,8 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, if (U_Star < CS%ustar_min) U_Star = CS%ustar_min if (CS%omega_frac < 1.0) then - absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & - (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + absf = 0.25*US%s_to_T*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif @@ -3429,81 +3429,81 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) CS%nkml = GV%nkml call log_param(param_file, mdl, "NKML", CS%nkml, & - "The number of sublayers within the mixed layer if \n"//& + "The number of sublayers within the mixed layer if "//& "BULKMIXEDLAYER is true.", units="nondim", default=2) CS%nkbl = GV%nk_rho_varies - GV%nkml call log_param(param_file, mdl, "NKBL", CS%nkbl, & - "The number of variable density buffer layers if \n"//& + "The number of variable density buffer layers if "//& "BULKMIXEDLAYER is true.", units="nondim", default=2) call get_param(param_file, mdl, "MSTAR", CS%mstar, & - "The ratio of the friction velocity cubed to the TKE \n"//& + "The ratio of the friction velocity cubed to the TKE "//& "input to the mixed layer.", "units=nondim", default=1.2) call get_param(param_file, mdl, "NSTAR", CS%nstar, & - "The portion of the buoyant potential energy imparted by \n"//& - "surface fluxes that is available to drive entrainment \n"//& + "The portion of the buoyant potential energy imparted by "//& + "surface fluxes that is available to drive entrainment "//& "at the base of mixed layer when that energy is positive.", & units="nondim", default=0.15) call get_param(param_file, mdl, "BULK_RI_ML", CS%bulk_Ri_ML, & - "The efficiency with which mean kinetic energy released \n"//& - "by mechanically forced entrainment of the mixed layer \n"//& + "The efficiency with which mean kinetic energy released "//& + "by mechanically forced entrainment of the mixed layer "//& "is converted to turbulent kinetic energy.", units="nondim",& fail_if_missing=.true.) call get_param(param_file, mdl, "ABSORB_ALL_SW", CS%absorb_all_sw, & - "If true, all shortwave radiation is absorbed by the \n"//& + "If true, all shortwave radiation is absorbed by the "//& "ocean, instead of passing through to the bottom mud.", & default=.false.) call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & - "TKE_DECAY relates the vertical rate of decay of the \n"//& - "TKE available for mechanical entrainment to the natural \n"//& + "TKE_DECAY relates the vertical rate of decay of the "//& + "TKE available for mechanical entrainment to the natural "//& "Ekman depth.", units="nondim", default=2.5) call get_param(param_file, mdl, "NSTAR2", CS%nstar2, & - "The portion of any potential energy released by \n"//& - "convective adjustment that is available to drive \n"//& - "entrainment at the base of mixed layer. By default \n"//& + "The portion of any potential energy released by "//& + "convective adjustment that is available to drive "//& + "entrainment at the base of mixed layer. By default "//& "NSTAR2=NSTAR.", units="nondim", default=CS%nstar) call get_param(param_file, mdl, "BULK_RI_CONVECTIVE", CS%bulk_Ri_convective, & - "The efficiency with which convectively released mean \n"//& - "kinetic energy is converted to turbulent kinetic \n"//& + "The efficiency with which convectively released mean "//& + "kinetic energy is converted to turbulent kinetic "//& "energy. By default BULK_RI_CONVECTIVE=BULK_RI_ML.", & units="nondim", default=CS%bulk_Ri_ML) call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & - "The minimum mixed layer depth if the mixed layer depth \n"//& + "The minimum mixed layer depth if the mixed layer depth "//& "is determined dynamically.", units="m", default=0.0, scale=GV%m_to_H, & unscaled=Hmix_min_m) call get_param(param_file, mdl, "LIMIT_BUFFER_DETRAIN", CS%limit_det, & - "If true, limit the detrainment from the buffer layers \n"//& + "If true, limit the detrainment from the buffer layers "//& "to not be too different from the neighbors.", default=.false.) call get_param(param_file, mdl, "ALLOWED_DETRAIN_TEMP_CHG", CS%Allowed_T_chg, & - "The amount by which temperature is allowed to exceed \n"//& + "The amount by which temperature is allowed to exceed "//& "previous values during detrainment.", units="K", default=0.5) call get_param(param_file, mdl, "ALLOWED_DETRAIN_SALT_CHG", CS%Allowed_S_chg, & - "The amount by which salinity is allowed to exceed \n"//& + "The amount by which salinity is allowed to exceed "//& "previous values during detrainment.", units="PSU", default=0.1) call get_param(param_file, mdl, "ML_DT_DS_WEIGHT", CS%dT_dS_wt, & - "When forced to extrapolate T & S to match the layer \n"//& - "densities, this factor (in deg C / PSU) is combined \n"//& - "with the derivatives of density with T & S to determine \n"//& - "what direction is orthogonal to density contours. It \n"//& - "should be a typical value of (dR/dS) / (dR/dT) in \n"//& + "When forced to extrapolate T & S to match the layer "//& + "densities, this factor (in deg C / PSU) is combined "//& + "with the derivatives of density with T & S to determine "//& + "what direction is orthogonal to density contours. It "//& + "should be a typical value of (dR/dS) / (dR/dT) in "//& "oceanic profiles.", units="degC PSU-1", default=6.0) call get_param(param_file, mdl, "BUFFER_LAYER_EXTRAP_LIMIT", CS%BL_extrap_lim, & - "A limit on the density range over which extrapolation \n"//& - "can occur when detraining from the buffer layers, \n"//& - "relative to the density range within the mixed and \n"//& - "buffer layers, when the detrainment is going into the \n"//& - "lightest interior layer, nondimensional, or a negative \n"//& + "A limit on the density range over which extrapolation "//& + "can occur when detraining from the buffer layers, "//& + "relative to the density range within the mixed and "//& + "buffer layers, when the detrainment is going into the "//& + "lightest interior layer, nondimensional, or a negative "//& "value not to apply this limit.", units="nondim", default = -1.0) call get_param(param_file, mdl, "DEPTH_LIMIT_FLUXES", CS%H_limit_fluxes, & - "The surface fluxes are scaled away when the total ocean \n"//& + "The surface fluxes are scaled away when the total ocean "//& "depth is less than DEPTH_LIMIT_FLUXES.", & units="m", default=0.1*Hmix_min_m, scale=GV%m_to_H) call get_param(param_file, mdl, "OMEGA",CS%omega, & "The rotation rate of the earth.", units="s-1", & default=7.2921e-5) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & - "If true, use the absolute rotation rate instead of the \n"//& - "vertical component of rotation when setting the decay \n"//& + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then @@ -3511,58 +3511,58 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & - "When setting the decay scale for turbulence, use this \n"//& - "fraction of the absolute rotation rate blended with the \n"//& + "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).", & units="nondim", default=omega_frac_dflt) call get_param(param_file, mdl, "ML_RESORT", CS%ML_resort, & - "If true, resort the topmost layers by potential density \n"//& + "If true, resort the topmost layers by potential density "//& "before the mixed layer calculations.", default=.false.) if (CS%ML_resort) & call get_param(param_file, mdl, "ML_PRESORT_NK_CONV_ADJ", CS%ML_presort_nz_conv_adj, & - "Convectively mix the first ML_PRESORT_NK_CONV_ADJ \n"//& + "Convectively mix the first ML_PRESORT_NK_CONV_ADJ "//& "layers before sorting when ML_RESORT is true.", & units="nondim", default=0, fail_if_missing=.true.) ! Fail added by AJA. ! This gives a minimum decay scale that is typically much less than Angstrom. ustar_min_dflt = 2e-4*CS%omega*(GV%Angstrom_m + GV%H_to_m*GV%H_subroundoff) call get_param(param_file, mdl, "BML_USTAR_MIN", CS%ustar_min, & - "The minimum value of ustar that should be used by the \n"//& - "bulk mixed layer model in setting vertical TKE decay \n"//& + "The minimum value of ustar that should be used by the "//& + "bulk mixed layer model in setting vertical TKE decay "//& "scales. This must be greater than 0.", units="m s-1", & default=ustar_min_dflt, scale=US%m_to_Z) if (CS%ustar_min<=0.0) call MOM_error(FATAL, "BML_USTAR_MIN must be positive.") call get_param(param_file, mdl, "RESOLVE_EKMAN", CS%Resolve_Ekman, & - "If true, the NKML>1 layers in the mixed layer are \n"//& - "chosen to optimally represent the impact of the Ekman \n"//& - "transport on the mixed layer TKE budget. Otherwise, \n"//& - "the sublayers are distributed uniformly through the \n"//& + "If true, the NKML>1 layers in the mixed layer are "//& + "chosen to optimally represent the impact of the Ekman "//& + "transport on the mixed layer TKE budget. Otherwise, "//& + "the sublayers are distributed uniformly through the "//& "mixed layer.", default=.false.) call get_param(param_file, mdl, "CORRECT_ABSORPTION_DEPTH", CS%correct_absorption, & - "If true, the average depth at which penetrating shortwave \n"//& - "radiation is absorbed is adjusted to match the average \n"//& - "heating depth of an exponential profile by moving some \n"//& + "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.", default=.false.) call get_param(param_file, mdl, "DO_RIVERMIX", CS%do_rivermix, & - "If true, apply additional mixing whereever there is \n"//& - "runoff, so that it is mixed down to RIVERMIX_DEPTH, \n"//& + "If true, apply additional mixing wherever there is "//& + "runoff, so that it is mixed down to RIVERMIX_DEPTH, "//& "if the ocean is that deep.", default=.false.) if (CS%do_rivermix) & call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & - "The depth to which rivers are mixed if DO_RIVERMIX is \n"//& + "The depth to which rivers are mixed if DO_RIVERMIX is "//& "defined.", units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & - "If true, use the fluxes%runoff_Hflx field to set the \n"//& + "If true, use the fluxes%runoff_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & default=.false.) call get_param(param_file, mdl, "USE_CALVING_HEAT_CONTENT", CS%use_calving_heat_content, & - "If true, use the fluxes%calving_Hflx field to set the \n"//& + "If true, use the fluxes%calving_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*froz_runoff.", & default=.false.) call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", & CS%allow_clocks_in_omp_loops, & - "If true, clocks can be called from inside loops that can \n"//& + "If true, clocks can be called from inside loops that can "//& "be threaded. To run with multiple threads, set to False.", & default=.true.) @@ -3602,17 +3602,17 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) !CS%lim_det_dH_sfc = 0.5 ; CS%lim_det_dH_bathy = 0.2 ! Technically these should not get used if limit_det is false? if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) then call get_param(param_file, mdl, "LIMIT_BUFFER_DET_DH_SFC", CS%lim_det_dH_sfc, & - "The fractional limit in the change between grid points \n"//& + "The fractional limit in the change between grid points "//& "of the surface region (mixed & buffer layer) thickness.", & units="nondim", default=0.5) call get_param(param_file, mdl, "LIMIT_BUFFER_DET_DH_BATHY", CS%lim_det_dH_bathy, & - "The fraction of the total depth by which the thickness \n"//& - "of the surface region (mixed & buffer layer) is allowed \n"//& + "The fraction of the total depth by which the thickness "//& + "of the surface region (mixed & buffer layer) is allowed "//& "to change between grid points.", units="nondim", default=0.2) endif call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, temperature and salinity are used as state \n"//& + "If true, temperature and salinity are used as state "//& "variables.", default=.true.) CS%nsw = 0 if (use_temperature) then diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index e8b4500bbc..5259d4ed25 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -322,10 +322,11 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) integer, optional, intent(in) :: halo !< Halo width over which to work ! local variables - real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement - real :: S_min !< The minimum salinity - real :: mc !< A layer's mass kg m-2 . + real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement [gSalt m-2] + real :: S_min !< The minimum salinity [ppt]. + real :: mc !< A layer's mass [kg m-2]. integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -333,17 +334,15 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) ! call cpu_clock_begin(id_clock_adjust_salt) -!### MAKE THIS A RUN_TIME PARAMETER. COULD IT BE 0? - S_min = 0.01 + S_min = tv%min_salinity salt_add_col(:,:) = 0.0 -!$OMP parallel do default(none) shared(is,ie,js,je,nz,G,GV,tv,h,salt_add_col, S_min) & -!$OMP private(mc) + !$OMP parallel do default(none) private(mc) do j=js,je do k=nz,1,-1 ; do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .and. & - ((tv%S(i,j,k) < S_min) .or. (salt_add_col(i,j) > 0.0))) then + if ( (G%mask2dT(i,j) > 0.0) .and. & + ((tv%S(i,j,k) < S_min) .or. (salt_add_col(i,j) > 0.0)) ) then mc = GV%H_to_kg_m2 * h(i,j,k) if (h(i,j,k) <= 10.0*GV%Angstrom_H) then ! Very thin layers should not be adjusted by the salt flux @@ -351,14 +350,12 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) salt_add_col(i,j) = salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) tv%S(i,j,k) = S_min endif + elseif (salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) <= 0.0) then + tv%S(i,j,k) = tv%S(i,j,k) - salt_add_col(i,j) / mc + salt_add_col(i,j) = 0.0 else - if (salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) <= 0.0) then - tv%S(i,j,k) = tv%S(i,j,k) - salt_add_col(i,j)/mc - salt_add_col(i,j) = 0.0 - else - salt_add_col(i,j) = salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) - tv%S(i,j,k) = S_min - endif + salt_add_col(i,j) = salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) + tv%S(i,j,k) = S_min endif endif enddo ; enddo @@ -643,7 +640,8 @@ end subroutine find_uv_at_h !> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. !> This routine is appropriate in MOM_diabatic_driver due to its position within the time stepping. -subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, id_N2subML, id_MLDsq) +subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & + id_N2subML, id_MLDsq, dz_subML) type(ocean_grid_type), intent(in) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -656,19 +654,25 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD + real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML + !! or 50 m if missing [Z ~> m] ! Local variables real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [kg m-3]. - real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [Pa]. - real, dimension(SZI_(G)) :: dK, dKm1, d1 ! Depths [Z ~> m]. - real, dimension(SZI_(G)) :: rhoSurf, rhoAtK, rho1 ! Densities used for N2 [kg m-3]. + real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [Pa]. + real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m]. + real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [degC]. + real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [ppt]. + real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [kg m-3]. + real, dimension(SZI_(G)) :: dK, dKm1 ! Depths [Z ~> m]. + real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixedlayer depth [kg m-3]. real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [s-2]. real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. - real :: Rho_x_gE ! The product of density, gravitational acceleartion and a unit - ! conversion factor [kg m-1 Z-1 s-2 ~> kg m-2 s-2]. + logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 + ! have been stored already. real :: gE_Rho0 ! The gravitational acceleration divided by a mean density [m4 s-2 kg-1]. - real :: dz_subML ! Depth below ML over which to diagnose stratification [Z ~> m]. + real :: dH_subML ! Depth below ML over which to diagnose stratification [H ~> m]. integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ real :: aFac, ddRho @@ -676,12 +680,12 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, id_SQ = -1 ; if (PRESENT(id_N2subML)) id_SQ = id_MLDsq - Rho_x_gE = GV%g_Earth * GV%Rho0 gE_rho0 = US%m_to_Z**2 * GV%g_Earth / GV%Rho0 - dz_subML = 50.*US%m_to_Z + dH_subML = 50.*GV%m_to_H ; if (present(dz_subML)) dH_subML = GV%Z_to_H*dz_subML is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - pRef_MLD(:) = 0. ; pRef_N2(:) = 0. + + pRef_MLD(:) = 0.0 do j=js,je do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is, ie-is+1, tv%eqn_of_state) @@ -689,11 +693,10 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, deltaRhoAtK(i) = 0. MLD(i,j) = 0. if (id_N2>0) then - subMLN2(i,j) = 0. - rho1(i) = 0. - d1(i) = 0. - pRef_N2(i) = Rho_x_gE * h(i,j,1) * GV%H_to_Z ! Boussinesq approximation!!!! ????? - !### This should be: pRef_N2(i) = GV%H_to_Pa * h(i,j,1) ! This might change answers at roundoff. + subMLN2(i,j) = 0.0 + H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. endif enddo do k=2,nz @@ -702,27 +705,23 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K enddo - ! Stratification, N2, immediately below the mixed layer, averaged over at least 50 m. + ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding + ! the cells that extend over at least dz_subML. if (id_N2>0) then - do i=is,ie - pRef_N2(i) = pRef_N2(i) + Rho_x_gE * h(i,j,k) * GV%H_to_Z ! Boussinesq approximation!!!! ????? - !### This should be: pRef_N2(i) = pRev_N2(i) + GV%H_to_Pa * h(i,j,k) - !### This might change answers at roundoff. - enddo - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_N2, rhoAtK, is, ie-is+1, tv%eqn_of_state) - do i=is,ie - if (MLD(i,j)>0. .and. subMLN2(i,j)==0.) then ! This block is below the mixed layer - if (d1(i)==0.) then ! Record the density, depth and pressure, immediately below the ML - rho1(i) = rhoAtK(i) - d1(i) = dK(i) - !### It looks to me like there is bad logic here. - RWH - ! Use pressure at the bottom of the upper layer used in calculating d/dz rho - pRef_N2(i) = pRef_N2(i) + Rho_x_gE * h(i,j,k) * GV%H_to_Z ! Boussinesq approximation!!!! ????? - !### This line should be: pRef_N2(i) = pRev_N2(i) + GV%H_to_Pa * h(i,j,k) - !### This might change answers at roundoff. - endif - if (d1(i)>0. .and. dK(i)-d1(i)>=dz_subML) then - subMLN2(i,j) = gE_rho0 * (rho1(i)-rhoAtK(i)) / (d1(i) - dK(i)) + do i=is,ie + if (MLD(i,j)==0.0) then ! Still in the mixed layer. + H_subML(i) = H_subML(i) + h(i,j,k) + elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. + if (dH_N2(i)==0.0) then ! Record the temperature, salinity, pressure, immediately below the ML + T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) + H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. + dH_N2(i) = 0.5 * h(i,j,k) + elseif (dH_N2(i) + h(i,j,k) < dH_subML) then + dH_N2(i) = dH_N2(i) + h(i,j,k) + else ! This layer includes the base of the region where N2 is calculated. + T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) + dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) + N2_region_set(i) = .true. endif endif enddo ! i-loop @@ -744,11 +743,21 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, enddo ! k-loop do i=is,ie if ((MLD(i,j)==0.) .and. (deltaRhoAtK(i)0 .and. subMLN2(i,j)==0. .and. d1(i)>0. .and. dK(i)-d1(i)>0.) then - ! ! Use what ever stratification we can, measured over what ever distance is available - ! subMLN2(i,j) = gE_rho0 * (rho1(i)-rhoAtK(i)) / (d1(i) - dK(i)) - ! endif enddo + + if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. + do i=is,ie ; pRef_N2(i) = GV%H_to_Pa * (H_subML(i) + 0.5*dH_N2(i)) ; enddo + ! if ((.not.N2_region_set(i)) .and. (dH_N2(i) > 0.5*dH_subML)) then + ! ! Use whatever stratification we can, measured over whatever distance is available? + ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) + ! N2_region_set(i) = .true. + ! endif + call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, is, ie-is+1, tv%eqn_of_state) + call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, is, ie-is+1, tv%eqn_of_state) + do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then + subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) + endif ; enddo + endif enddo ! j-loop if (id_MLD > 0) call post_data(id_MLD, MLD, diagPtr) @@ -1101,13 +1110,12 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, h, tv, & ! Diagnostics of heat content associated with mass fluxes if (associated(fluxes%heat_content_massin)) & fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & - tv%T(i,j,k) * max(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt + T2d(i,k) * max(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & - tv%T(i,j,k) * min(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt + T2d(i,k) * min(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & - tv%T(i,j,k) * dThickness * GV%H_to_kg_m2 -!### NOTE: tv%T should be T2d in the expressions above. + T2d(i,k) * dThickness * GV%H_to_kg_m2 ! Update state by the appropriate increment. hOld = h2d(i,k) ! Keep original thickness in hand @@ -1329,31 +1337,31 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori "The following parameters are used for auxiliary diabatic processes.") call get_param(param_file, mdl, "RECLAIM_FRAZIL", CS%reclaim_frazil, & - "If true, try to use any frazil heat deficit to cool any\n"//& - "overlying layers down to the freezing point, thereby \n"//& - "avoiding the creation of thin ice when the SST is above \n"//& + "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.", default=.true.) call get_param(param_file, mdl, "PRESSURE_DEPENDENT_FRAZIL", & CS%pressure_dependent_frazil, & - "If true, use a pressure dependent freezing temperature \n"//& - "when making frazil. The default is false, which will be \n"//& + "If true, use a pressure dependent freezing temperature "//& + "when making frazil. The default is false, which will be "//& "faster but is inappropriate with ice-shelf cavities.", & default=.false.) if (use_ePBL) then call get_param(param_file, mdl, "IGNORE_FLUXES_OVER_LAND", CS%ignore_fluxes_over_land,& - "If true, the model does not check if fluxes are being applied\n"//& - "over land points. This is needed when the ocean is coupled \n"//& - "with ice shelves and sea ice, since the sea ice mask needs to \n"//& - "be different than the ocean mask to avoid sea ice formation \n"//& + "If true, the model does not check if fluxes are being applied "//& + "over land points. This is needed when the ocean is coupled "//& + "with ice shelves and sea ice, since the sea ice mask needs to "//& + "be different than the ocean mask to avoid sea ice formation "//& "under ice shelves. This flag only works when use_ePBL = True.", default=.false.) call get_param(param_file, mdl, "DO_RIVERMIX", CS%do_rivermix, & - "If true, apply additional mixing whereever there is \n"//& - "runoff, so that it is mixed down to RIVERMIX_DEPTH \n"//& + "If true, apply additional mixing wherever there is "//& + "runoff, so that it is mixed down to RIVERMIX_DEPTH "//& "if the ocean is that deep.", default=.false.) if (CS%do_rivermix) & call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & - "The depth to which rivers are mixed if DO_RIVERMIX is \n"//& + "The depth to which rivers are mixed if DO_RIVERMIX is "//& "defined.", units="m", default=0.0, scale=US%m_to_Z) else CS%do_rivermix = .false. ; CS%rivermix_depth = 0.0 ; CS%ignore_fluxes_over_land = .false. @@ -1361,11 +1369,11 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori if (GV%nkml == 0) then call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & - "If true, use the fluxes%runoff_Hflx field to set the \n"//& + "If true, use the fluxes%runoff_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & default=.false.) call get_param(param_file, mdl, "USE_CALVING_HEAT_CONTENT", CS%use_calving_heat_content, & - "If true, use the fluxes%calving_Hflx field to set the \n"//& + "If true, use the fluxes%calving_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*froz_runoff.", & default=.false.) else diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 200d3efdf7..ebe5c4062a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -174,6 +174,8 @@ module MOM_diabatic_driver logical :: debug_energy_req !< If true, test the mixing energy requirement code. type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output real :: MLDdensityDifference !< Density difference used to determine MLD_user + real :: dz_subML_N2 !< The distance over which to calculate a diagnostic of the + !! average stratification at the base of the mixed layer [Z ~> m]. integer :: nsw !< SW_NBANDS !>@{ Diagnostic IDs @@ -298,7 +300,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! one time step [H ~> m or kg m-2] eb_t, & ! amount of fluid entrained from the layer below within ! one time step [H ~> m or kg m-2] - Kd_lay, & ! diapycnal diffusivity of layers [Z2 s-1 ~> m2 s-1] + Kd_lay, & ! diapycnal diffusivity of layers [Z2 T-1 ~> m2 s-1] h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] h_prebound, & ! initial layer thicknesses [H ~> m or kg m-2] ! hold, & ! layer thickness before diapycnal entrainment, and later @@ -329,7 +331,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! near the boundaries [H ~> m or kg m-2] (for Bous or non-Bouss) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), target :: & - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 s-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] Kd_heat, & ! diapycnal diffusivity of heat [Z2 s-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 s-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 s-1 ~> m2 s-1] @@ -422,6 +424,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & eaml => eatr ; ebml => ebtr ! inverse time step + if (dt == 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "diabatic was called with a zero length timestep.") + if (dt < 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "diabatic was called with a negative timestep.") Idt = 1.0 / dt if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & @@ -572,8 +578,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_salt(i,j,k) = Kd_int(i,j,K) - Kd_heat(i,j,k) = Kd_int(i,j,K) + Kd_salt(i,j,k) = US%s_to_T * Kd_int(i,j,K) + Kd_heat(i,j,k) = US%s_to_T * Kd_int(i,j,K) enddo ; enddo ; enddo ! Add contribution from double diffusion if (associated(visc%Kd_extra_S)) then @@ -1096,7 +1102,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03, G, GV, US, CS%diag, & - id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq) + id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) endif if (CS%id_MLD_0125 > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, US, CS%diag) @@ -1178,7 +1184,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en ! one time step [H ~> m or kg m-2] eb, & ! amount of fluid entrained from the layer below within ! one time step [H ~> m or kg m-2] - Kd_lay, & ! diapycnal diffusivity of layers [Z2 s-1 ~> m2 s-1] + Kd_lay, & ! diapycnal diffusivity of layers [Z2 T-1 ~> m2 s-1] h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] h_prebound, & ! initial layer thicknesses [H ~> m or kg m-2] hold, & ! layer thickness before diapycnal entrainment, and later @@ -1211,7 +1217,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en ! near the boundaries [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), target :: & - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 s-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] Kd_heat, & ! diapycnal diffusivity of heat [Z2 s-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 s-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 s-1 ~> m2 s-1] @@ -1301,6 +1307,10 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en eaml => eatr ; ebml => ebtr ! inverse time step + if (dt == 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "legacy_diabatic was called with a zero length timestep.") + if (dt < 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "legacy_diabatic was called with a negative timestep.") Idt = 1.0 / dt if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & @@ -1502,8 +1512,10 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G) - call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=US%Z_to_m**2) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) endif @@ -1520,8 +1532,8 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_salt(i,j,k) = Kd_int(i,j,K) - Kd_heat(i,j,k) = Kd_int(i,j,K) + Kd_salt(i,j,k) = US%s_to_T * Kd_int(i,j,K) + Kd_heat(i,j,k) = US%s_to_T * Kd_int(i,j,K) enddo ; enddo ; enddo if (associated(visc%Kd_extra_S)) then !$OMP parallel do default(shared) @@ -1552,18 +1564,18 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en if (.not. CS%KPPisPassive) then !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_int(i,j,K) = min( Kd_salt(i,j,k), Kd_heat(i,j,k) ) + Kd_int(i,j,K) = US%T_to_s * min( Kd_salt(i,j,k), Kd_heat(i,j,k) ) enddo ; enddo ; enddo if (associated(visc%Kd_extra_S)) then !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kd_extra_S(i,j,k) = (Kd_salt(i,j,k) - Kd_int(i,j,K)) + visc%Kd_extra_S(i,j,k) = (Kd_salt(i,j,k) - US%s_to_T * Kd_int(i,j,K)) enddo ; enddo ; enddo endif if (associated(visc%Kd_extra_T)) then !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kd_extra_T(i,j,k) = (Kd_heat(i,j,k) - Kd_int(i,j,K)) + visc%Kd_extra_T(i,j,k) = (Kd_heat(i,j,k) - US%s_to_T * Kd_int(i,j,K)) enddo ; enddo ; enddo endif endif ! not passive @@ -1574,8 +1586,10 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en call MOM_state_chksum("after KPP", u, v, h, G, GV, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G) - call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=US%Z_to_m**2) - call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) + call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) endif endif ! endif for KPP @@ -1587,7 +1601,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en !!!!!!!! GMM, the following needs to be checked !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !### The vertical extent here is more limited that Kv_slow or Kd_int; it might be k=1,nz+1. do k=1,nz ; do j=js,je ; do i=is,ie - Kd_int(i,j,K) = Kd_int(i,j,K) + CS%CVMix_conv_csp%kd_conv(i,j,k) + Kd_int(i,j,K) = Kd_int(i,j,K) + US%T_to_s * CS%CVMix_conv_csp%kd_conv(i,j,k) visc%Kv_slow(i,j,k) = visc%Kv_slow(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) enddo ; enddo ; enddo !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1654,7 +1668,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en !$OMP private(hval) do k=2,nz ; do j=js,je ; do i=is,ie hval=1.0/(h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ea(i,j,k) = (GV%Z_to_H**2) * dt * hval * Kd_int(i,j,K) + ea(i,j,k) = (GV%Z_to_H**2) * dt * hval * (US%s_to_T * Kd_int(i,j,K)) eb(i,j,k-1) = ea(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie @@ -1668,8 +1682,9 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en call cpu_clock_begin(id_clock_entrain) ! Calculate appropriately limited diapycnal mass fluxes to account ! for diapycnal diffusion and advection. Sets: ea, eb. Changes: kb + ! XXX: Need to remove those US%s_to_T array multiply ops call Entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, US, CS%entrain_diffusive_CSp, & - ea, eb, kb, Kd_Lay=Kd_lay, Kd_int=Kd_int) + ea, eb, kb, Kd_lay=Kd_lay, Kd_int=Kd_int) call cpu_clock_end(id_clock_entrain) if (showCallTree) call callTree_waypoint("done with Entrainment_diffusive (diabatic)") @@ -1741,11 +1756,11 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) eb(i,j,k-1) = eb(i,j,k-1) + Ent_int ea(i,j,k) = ea(i,j,k) + Ent_int - Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here + Kd_int(i,j,K) = Kd_int(i,j,K) + US%T_to_s * Kd_add_here ! for diagnostics - Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_int(i,j,K) - Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_int(i,j,K) + Kd_heat(i,j,K) = Kd_heat(i,j,K) + US%T_to_s * Kd_int(i,j,K) + Kd_salt(i,j,K) = Kd_salt(i,j,K) + US%T_to_s * Kd_int(i,j,K) enddo ; enddo ; enddo @@ -2389,7 +2404,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03, G, GV, US, CS%diag, & - id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq) + id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) endif if (CS%id_MLD_0125 > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, US, CS%diag) @@ -2506,7 +2521,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Idt = 1/dt + Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt work_3d(:,:,:) = 0.0 work_2d(:,:) = 0.0 @@ -2596,7 +2611,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Idt = 1/dt + Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt work_3d(:,:,:) = 0.0 work_2d(:,:) = 0.0 @@ -2683,7 +2698,7 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, CS) integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Idt = 1/dt + Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt ! temperature tendency if (CS%id_frazil_temp_tend > 0) then @@ -2810,27 +2825,27 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call log_version(param_file, mdl, version, & "The following parameters are used for diabatic processes.") call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& - "specified via calls to initialize_sponge and possibly \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified via calls to initialize_sponge and possibly "//& "set_up_sponge_field.", default=.false.) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, temperature and salinity are used as state \n"//& + "If true, temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", CS%use_energetic_PBL, & - "If true, use an implied energetics planetary boundary \n"//& - "layer scheme to determine the diffusivity and viscosity \n"//& + "If true, use an implied energetics planetary boundary "//& + "layer scheme to determine the diffusivity and viscosity "//& "in the surface boundary layer.", default=.false.) call get_param(param_file, mdl, "EPBL_IS_ADDITIVE", CS%ePBL_is_additive, & - "If true, the diffusivity from ePBL is added to all\n"//& - "other diffusivities. Otherwise, the larger of kappa-\n"//& - "shear and ePBL diffusivities are used.", default=.true.) + "If true, the diffusivity from ePBL is added to all "//& + "other diffusivities. Otherwise, the larger of kappa-shear "//& + "and ePBL diffusivities are used.", default=.true.) call get_param(param_file, mdl, "DOUBLE_DIFFUSION", differentialDiffusion, & "If true, apply parameterization of double-diffusion.", & default=.false. ) call get_param(param_file, mdl, "USE_KPP", CS%use_KPP, & - "If true, turns on the [CVMix] KPP scheme of Large et al., 1994,\n"// & - "to calculate diffusivities and non-local transport in the OBL.", & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& + "to calculate diffusivities and non-local transport in the OBL.", & default=.false., do_not_log=.true.) CS%use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) @@ -2845,7 +2860,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (CS%bulkmixedlayer) then call get_param(param_file, mdl, "ML_MIX_FIRST", CS%ML_mix_first, & - "The fraction of the mixed layer mixing that is applied \n"//& + "The fraction of the mixed layer mixing that is applied "//& "before interior diapycnal mixing. 0 by default.", & units="nondim", default=0.0) call get_param(param_file, mdl, "NKBL", CS%nkbl, default=2, do_not_log=.true.) @@ -2859,13 +2874,13 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%use_geothermal = .false. endif call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & - "If true, use the code that advances a separate set of \n"//& + "If true, use the code that advances a separate set of "//& "equations for the internal tide energy density.", default=.false.) CS%nMode = 1 if (CS%use_int_tides) then ! SET NUMBER OF MODES TO CONSIDER call get_param(param_file, mdl, "INTERNAL_TIDE_MODES", CS%nMode, & - "The number of distinct internal tide modes \n"//& + "The number of distinct internal tide modes "//& "that will be calculated.", default=1, do_not_log=.true.) ! The following parameters are used in testing the internal tide code. @@ -2894,19 +2909,18 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call get_param(param_file, mdl, "MASSLESS_MATCH_TARGETS", & CS%massless_match_targets, & - "If true, the temperature and salinity of massless layers \n"//& - "are kept consistent with their target densities. \n"//& - "Otherwise the properties of massless layers evolve \n"//& + "If true, the temperature and salinity of massless layers "//& + "are kept consistent with their target densities. "//& + "Otherwise the properties of massless layers evolve "//& "diffusively to match massive neighboring layers.", & default=.true.) call get_param(param_file, mdl, "AGGREGATE_FW_FORCING", CS%aggregate_FW_forcing, & - "If true, the net incoming and outgoing fresh water fluxes are combined\n"//& - "and applied as either incoming or outgoing depending on the sign of the net.\n"//& - "If false, the net incoming fresh water flux is added to the model and\n"//& - "thereafter the net outgoing is removed from the updated state."//& - "into the first non-vanished layer for which the column remains stable", & - default=.true.) + "If true, the net incoming and outgoing fresh water fluxes are combined "//& + "and applied as either incoming or outgoing depending on the sign of the net. "//& + "If false, the net incoming fresh water flux is added to the model and "//& + "thereafter the net outgoing is removed from the topmost non-vanished "//& + "layers of the updated state.", default=.true.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & @@ -2918,36 +2932,36 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call get_param(param_file, mdl, "DEBUG_ENERGY_REQ", CS%debug_energy_req, & "If true, debug the energy requirements.", default=.false., do_not_log=.true.) call get_param(param_file, mdl, "MIX_BOUNDARY_TRACERS", CS%mix_boundary_tracers, & - "If true, mix the passive tracers in massless layers at \n"//& - "the bottom into the interior as though a diffusivity of \n"//& + "If true, mix the passive tracers in massless layers at "//& + "the bottom into the interior as though a diffusivity of "//& "KD_MIN_TR were operating.", default=.true.) if (CS%mix_boundary_tracers) then call get_param(param_file, mdl, "KD", Kd, fail_if_missing=.true.) call get_param(param_file, mdl, "KD_MIN_TR", CS%Kd_min_tr, & - "A minimal diffusivity that should always be applied to \n"//& - "tracers, especially in massless layers near the bottom. \n"//& + "A minimal diffusivity that should always be applied to "//& + "tracers, especially in massless layers near the bottom. "//& "The default is 0.1*KD.", units="m2 s-1", default=0.1*Kd, scale=US%m_to_Z**2) call get_param(param_file, mdl, "KD_BBL_TR", CS%Kd_BBL_tr, & - "A bottom boundary layer tracer diffusivity that will \n"//& - "allow for explicitly specified bottom fluxes. The \n"//& - "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) \n"//& + "A bottom boundary layer tracer diffusivity that will "//& + "allow for explicitly specified bottom fluxes. The "//& + "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) "//& "over the same distance.", units="m2 s-1", default=0., scale=US%m_to_Z**2) endif call get_param(param_file, mdl, "TRACER_TRIDIAG", CS%tracer_tridiag, & - "If true, use the passive tracer tridiagonal solver for T and S\n", & + "If true, use the passive tracer tridiagonal solver for T and S", & default=.false.) call get_param(param_file, mdl, "MINIMUM_FORCING_DEPTH", CS%minimum_forcing_depth, & - "The smallest depth over which forcing can be applied. This\n"//& - "only takes effect when near-surface layers become thin\n"//& - "relative to this scale, in which case the forcing tendencies\n"//& + "The smallest depth over which forcing can be applied. This "//& + "only takes effect when near-surface layers become thin "//& + "relative to this scale, in which case the forcing tendencies "//& "scaled down by distributing the forcing over this depth scale.", & units="m", default=0.001) call get_param(param_file, mdl, "EVAP_CFL_LIMIT", CS%evap_CFL_limit, & - "The largest fraction of a layer than can be lost to forcing\n"//& - "(e.g. evaporation, sea-ice formation) in one time-step. The unused\n"//& + "The largest fraction of a layer than can be lost to forcing "//& + "(e.g. evaporation, sea-ice formation) in one time-step. The unused "//& "mass loss is passed down through the column.", & units="nondim", default=0.8) @@ -3018,10 +3032,14 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_MLD_user = register_diag_field('ocean_model','MLD_user',diag%axesT1,Time, & 'Mixed layer depth (used defined)', 'm', conversion=US%Z_to_m) call get_param(param_file, mdl, "DIAG_MLD_DENSITY_DIFF", CS%MLDdensityDifference, & - "The density difference used to determine a diagnostic mixed\n"//& - "layer depth, MLD_user, following the definition of Levitus 1982. \n"//& - "The MLD is the depth at which the density is larger than the\n"//& + "The density difference used to determine a diagnostic mixed "//& + "layer depth, MLD_user, following the definition of Levitus 1982. "//& + "The MLD is the depth at which the density is larger than the "//& "surface density by the specified amount.", units='kg/m3', default=0.1) + call get_param(param_file, mdl, "DIAG_DEPTH_SUBML_N2", CS%dz_subML_N2, & + "The distance over which to calculate a diagnostic of the "//& + "stratification at the base of the mixed layer.", & + units='m', default=50.0, scale=US%m_to_Z) ! diagnostics making use of the z-gridding code if (associated(diag_to_Z_CSp)) then @@ -3068,7 +3086,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di !call set_diffusivity_init(Time, G, param_file, diag, CS%set_diff_CSp, diag_to_Z_CSp, CS%int_tide_CSp) CS%id_Kd_interface = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & - 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z_to_m**2) + 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) if (CS%use_energetic_PBL) then CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z_to_m**2) @@ -3105,7 +3123,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif call get_param(param_file, mdl, "SALT_REJECT_BELOW_ML", CS%salt_reject_below_ML, & - "If true, place salt from brine rejection below the mixed layer,\n"// & + "If true, place salt from brine rejection below the mixed layer, "// & "into the first non-vanished layer for which the column remains stable", & default=.false.) diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 53e4b29178..3d9fb3c6c7 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -95,8 +95,8 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) enddo ustar = 0.01*US%m_to_Z ! Change this to being an input parameter? - absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) + absf = 0.25*US%s_to_T*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) Kd(1) = 0.0 ; Kd(nz+1) = 0.0 do K=2,nz tmp1 = h_top(K) * h_bot(K) * GV%H_to_Z @@ -1291,14 +1291,14 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENERGY_REQ_KH_SCALING", CS%test_Kh_scaling, & - "A scaling factor for the diapycnal diffusivity used in \n"//& + "A scaling factor for the diapycnal diffusivity used in "//& "testing the energy requirements.", default=1.0, units="nondim") call get_param(param_file, mdl, "ENERGY_REQ_COL_HT_SCALING", CS%ColHt_scaling, & - "A scaling factor for the column height change correction \n"//& + "A scaling factor for the column height change correction "//& "used in testing the energy requirements.", default=1.0, units="nondim") call get_param(param_file, mdl, "ENERGY_REQ_USE_TEST_PROFILE", & CS%use_test_Kh_profile, & - "If true, use the internal test diffusivity profile in \n"//& + "If true, use the internal test diffusivity profile in "//& "place of any that might be passed in as an argument.", default=.false.) CS%id_ERt = register_diag_field('ocean_model', 'EnReqTest_ERt', diag%axesZi, Time, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 5d4d70ec30..303f700deb 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -624,8 +624,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS Bf_Unstable = min(0.0, buoy_flux(i,j)) ! Negative for unstable if (CS%omega_frac >= 1.0) then ; absf(i) = 2.0*CS%omega else - absf(i) = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & - (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + absf(i) = 0.25*US%s_to_T*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) if (CS%omega_frac > 0.0) & absf(i) = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf(i)**2) endif @@ -2048,68 +2048,68 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) " 2 for MSTAR w/ L_E/L_O in stabilizing limit.",& "units=nondim",default=0) call get_param(param_file, mdl, "MSTAR", CS%mstar, & - "The ratio of the friction velocity cubed to the TKE \n"//& + "The ratio of the friction velocity cubed to the TKE "//& "input to the mixed layer.", "units=nondim", default=1.2) call get_param(param_file, mdl, "MIX_LEN_EXPONENT", CS%MixLenExponent, & - "The exponent applied to the ratio of the distance to the MLD \n"//& + "The exponent applied to the ratio of the distance to the MLD "//& "and the MLD depth which determines the shape of the mixing length.",& "units=nondim", default=2.0) call get_param(param_file, mdl, "MSTAR_CAP", CS%mstar_cap, & - "Maximum value of mstar allowed in model if non-negative\n"//& + "Maximum value of mstar allowed in model if non-negative "//& "(used if MSTAR_MODE>0).",& "units=nondim", default=-1.0) call get_param(param_file, mdl, "MSTAR_CONV_ADJ", CS%cnv_mst_fac, & - "Factor used for reducing mstar during convection \n"//& - " due to reduction of stable density gradient.",& + "Factor used for reducing mstar during convection "//& + "due to reduction of stable density gradient.",& "units=nondim", default=0.0) call get_param(param_file, mdl, "MSTAR_SLOPE", CS%mstar_slope, & - "The slope of the linear relationship between mstar \n"//& + "The slope of the linear relationship between mstar "//& "and the length scale ratio (used if MSTAR_MODE=1).",& "units=nondim", default=0.85) call get_param(param_file, mdl, "MSTAR_XINT", CS%mstar_xint, & - "The value of the length scale ratio where the mstar \n"//& + "The value of the length scale ratio where the mstar "//& "is linear above (used if MSTAR_MODE=1).",& "units=nondim", default=-0.3) call get_param(param_file, mdl, "MSTAR_AT_XINT", CS%mstar_at_xint, & - "The value of mstar at MSTAR_XINT \n"//& + "The value of mstar at MSTAR_XINT "//& "(used if MSTAR_MODE=1).",& "units=nondim", default=0.095) call get_param(param_file, mdl, "MSTAR_FLATCAP", CS%MSTAR_FLATCAP, & - "Set false to use asymptotic cap, defaults to true.\n"//& + "Set false to use asymptotic cap, defaults to true. "//& "(used only if MSTAR_MODE=1)"& ,"units=nondim",default=.true.) call get_param(param_file, mdl, "MSTAR2_COEF1", CS%MSTAR_COEF, & - "Coefficient in computing mstar when rotation and \n"//& - " stabilizing effects are both important (used if MSTAR_MODE=2)"& + "Coefficient in computing mstar when rotation and "//& + "stabilizing effects are both important (used if MSTAR_MODE=2)"& ,"units=nondim",default=0.3) call get_param(param_file, mdl, "MSTAR2_COEF2", CS%C_EK, & - "Coefficient in computing mstar when only rotation limits \n"//& - " the total mixing. (used only if MSTAR_MODE=2)"& + "Coefficient in computing mstar when only rotation limits "//& + "the total mixing. (used only if MSTAR_MODE=2)"& ,"units=nondim",default=0.085) call get_param(param_file, mdl, "NSTAR", CS%nstar, & - "The portion of the buoyant potential energy imparted by \n"//& - "surface fluxes that is available to drive entrainment \n"//& + "The portion of the buoyant potential energy imparted by "//& + "surface fluxes that is available to drive entrainment "//& "at the base of mixed layer when that energy is positive.", & units="nondim", default=0.2) call get_param(param_file, mdl, "MKE_TO_TKE_EFFIC", CS%MKE_to_TKE_effic, & - "The efficiency with which mean kinetic energy released \n"//& - "by mechanically forced entrainment of the mixed layer \n"//& + "The efficiency with which mean kinetic energy released "//& + "by mechanically forced entrainment of the mixed layer "//& "is converted to turbulent kinetic energy.", units="nondim", & default=0.0) call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & - "TKE_DECAY relates the vertical rate of decay of the \n"//& - "TKE available for mechanical entrainment to the natural \n"//& + "TKE_DECAY relates the vertical rate of decay of the "//& + "TKE available for mechanical entrainment to the natural "//& "Ekman depth.", units="nondim", default=2.5) ! call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & -! "The minimum mixed layer depth if the mixed layer depth \n"//& +! "The minimum mixed layer depth if the mixed layer depth "//& ! "is determined dynamically.", units="m", default=0.0) call get_param(param_file, mdl, "OMEGA",CS%omega, & "The rotation rate of the earth.", units="s-1", & default=7.2921e-5) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & - "If true, use the absolute rotation rate instead of the \n"//& - "vertical component of rotation when setting the decay \n"// & + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "// & "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then @@ -2117,51 +2117,51 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & - "When setting the decay scale for turbulence, use this \n"// & - "fraction of the absolute rotation rate blended with the \n"//& + "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).", & units="nondim", default=omega_frac_dflt) call get_param(param_file, mdl, "WSTAR_USTAR_COEF", CS%wstar_ustar_coef, & - "A ratio relating the efficiency with which convectively \n"//& - "released energy is converted to a turbulent velocity, \n"// & - "relative to mechanically forced TKE. Making this larger \n"//& + "A ratio relating the efficiency with which convectively "//& + "released energy is converted to a turbulent velocity, "// & + "relative to mechanically forced TKE. Making this larger "//& "increases the BL diffusivity", units="nondim", default=1.0) call get_param(param_file, mdl, "VSTAR_SCALE_FACTOR", CS%vstar_scale_fac, & - "An overall nondimensional scaling factor for v*. \n"// & + "An overall nondimensional scaling factor for v*. "// & "Making this larger decreases the PBL diffusivity.", & units="nondim", default=1.0, scale=US%m_to_Z) call get_param(param_file, mdl, "EKMAN_SCALE_COEF", CS%Ekman_scale_coef, & - "A nondimensional scaling factor controlling the inhibition \n"// & - "of the diffusive length scale by rotation. Making this larger \n"//& + "A nondimensional scaling factor controlling the inhibition "// & + "of the diffusive length scale by rotation. Making this larger "//& "decreases the PBL diffusivity.", units="nondim", default=1.0) call get_param(param_file, mdl, "USE_MLD_ITERATION", CS%USE_MLD_ITERATION, & - "A logical that specifies whether or not to use the \n"// & - "distance to the bottom of the actively turblent boundary \n"//& + "A logical that specifies whether or not to use the "// & + "distance to the bottom of the actively turbulent boundary "//& "layer to help set the EPBL length scale.", default=.false.) call get_param(param_file, mdl, "ORIG_MLD_ITERATION", CS%ORIG_MLD_ITERATION, & - "A logical that specifies whether or not to use the \n"// & - "old method for determining MLD depth in iteration, which \n"//& + "A logical that specifies whether or not to use the "// & + "old method for determining MLD depth in iteration, which "//& "is limited to resolution.", default=.true.) call get_param(param_file, mdl, "MLD_ITERATION_GUESS", CS%MLD_ITERATION_GUESS, & - "A logical that specifies whether or not to use the \n"// & - "previous timestep MLD as a first guess in the MLD iteration.\n"// & + "A logical that specifies whether or not to use the "// & + "previous timestep MLD as a first guess in the MLD iteration. "// & "The default is false to facilitate reproducibility.", default=.false.) call get_param(param_file, mdl, "EPBL_MLD_TOLERANCE", CS%MLD_tol, & - "The tolerance for the iteratively determined mixed \n"// & + "The tolerance for the iteratively determined mixed "// & "layer depth. This is only used with USE_MLD_ITERATION.", & units="meter", default=1.0, scale=US%m_to_Z) call get_param(param_file, mdl, "EPBL_MIN_MIX_LEN", CS%min_mix_len, & - "The minimum mixing length scale that will be used \n"//& + "The minimum mixing length scale that will be used "//& "by ePBL. The default (0) does not set a minimum.", & units="meter", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "EPBL_ORIGINAL_PE_CALC", CS%orig_PE_calc, & - "If true, the ePBL code uses the original form of the \n"// & - "potential energy change code. Otherwise, the newer \n"// & - "version that can work with successive increments to the \n"// & + "If true, the ePBL code uses the original form of the "// & + "potential energy change code. Otherwise, the newer "// & + "version that can work with successive increments to the "// & "diffusivity in upward or downward passes is used.", default=.true.) call get_param(param_file, mdl, "EPBL_TRANSITION_SCALE", CS%transLay_scale, & - "A scale for the mixing length in the transition layer \n"// & - "at the edge of the boundary layer as a fraction of the \n"//& + "A scale for the mixing length in the transition layer "// & + "at the edge of the boundary layer as a fraction of the "//& "boundary layer thickness. The default is 0.1.", & units="nondim", default=0.1) if ( CS%USE_MLD_ITERATION .and. abs(CS%transLay_scale-0.5) >= 0.5) then @@ -2169,19 +2169,18 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "EPBL_TRANSITION should be greater than 0 and less than 1.") endif call get_param(param_file, mdl, "N2_DISSIPATION_POS", CS%N2_Dissipation_Scale_Pos, & - "A scale for the dissipation of TKE due to stratification \n"// & - "in the boundary layer, applied when local stratification \n"// & + "A scale for the dissipation of TKE due to stratification "// & + "in the boundary layer, applied when local stratification "// & "is positive. The default is 0, but should probably be ~0.4.", & units="nondim", default=0.0) call get_param(param_file, mdl, "N2_DISSIPATION_NEG", CS%N2_Dissipation_Scale_Neg,& - "A scale for the dissipation of TKE due to stratification \n"// & - "in the boundary layer, applied when local stratification \n"// & + "A scale for the dissipation of TKE due to stratification "// & + "in the boundary layer, applied when local stratification "// & "is negative. The default is 0, but should probably be ~1.", & units="nondim", default=0.0) call get_param(param_file, mdl, "USE_LA_LI2016", USE_LA_Windsea, & - "A logical to use the Li et al. 2016 (submitted) formula to \n"//& - " determine the Langmuir number.", & - units="nondim", default=.false.) + "A logical to use the Li et al. 2016 (submitted) formula to "//& + "determine the Langmuir number.", units="nondim", default=.false.) ! Note this can be activated in other ways, but this preserves the old method. if (use_la_windsea) then CS%USE_LT = .true. @@ -2206,30 +2205,30 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "Exponent for Langmuir enhancement if LT_ENHANCE > 1", & units="nondim", default=-1.33) call get_param(param_file, mdl, "LT_MOD_LAC1", CS%LaC_MLDoEK, & - "Coefficient for modification of Langmuir number due to\n"//& - " MLD approaching Ekman depth if LT_ENHANCE=2.", & + "Coefficient for modification of Langmuir number due to "//& + "MLD approaching Ekman depth if LT_ENHANCE=2.", & units="nondim", default=-0.87) call get_param(param_file, mdl, "LT_MOD_LAC2", CS%LaC_MLDoOB_stab, & - "Coefficient for modification of Langmuir number due to\n"// & - " MLD approaching stable Obukhov depth if LT_ENHANCE=2.", & + "Coefficient for modification of Langmuir number due to "// & + "MLD approaching stable Obukhov depth if LT_ENHANCE=2.", & units="nondim", default=0.0) call get_param(param_file, mdl, "LT_MOD_LAC3", CS%LaC_MLDoOB_un, & - "Coefficient for modification of Langmuir number due to\n"//& - " MLD approaching unstable Obukhov depth if LT_ENHANCE=2.", & + "Coefficient for modification of Langmuir number due to "//& + "MLD approaching unstable Obukhov depth if LT_ENHANCE=2.", & units="nondim", default=0.0) call get_param(param_file, mdl, "LT_MOD_LAC4", CS%Lac_EKoOB_stab, & - "Coefficient for modification of Langmuir number due to\n"// & - " ratio of Ekman to stable Obukhov depth if LT_ENHANCE=2.", & + "Coefficient for modification of Langmuir number due to "// & + "ratio of Ekman to stable Obukhov depth if LT_ENHANCE=2.", & units="nondim", default=0.95) call get_param(param_file, mdl, "LT_MOD_LAC5", CS%Lac_EKoOB_un, & - "Coefficient for modification of Langmuir number due to\n"// & - " ratio of Ekman to unstable Obukhov depth if LT_ENHANCE=2.",& + "Coefficient for modification of Langmuir number due to "// & + "ratio of Ekman to unstable Obukhov depth if LT_ENHANCE=2.",& units="nondim", default=0.95) endif ! This gives a minimum decay scale that is typically much less than Angstrom. CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) call log_param(param_file, mdl, "EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m, & - "The (tiny) minimum friction velocity used within the \n"//& + "The (tiny) minimum friction velocity used within the "//& "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1") CS%id_ML_depth = register_diag_field('ocean_model', 'ePBL_h_ML', diag%axesT1, & @@ -2278,7 +2277,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) Time, 'MSTAR applied for LT effect.', 'nondim') call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, temperature and salinity are used as state \n"//& + "If true, temperature and salinity are used as state "//& "variables.", default=.true.) if (max(CS%id_TKE_wind, CS%id_TKE_MKE, CS%id_TKE_conv, & diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 824bab78b2..34b48257bb 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -79,10 +79,10 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, US, CS, ea, eb, ! At least one of the two following arguments must be present. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & optional, intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. ! This subroutine calculates ea and eb, the rates at which a layer entrains ! from the layers above and below. The entrainment rates are proportional to @@ -271,23 +271,25 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, US, CS, ea, eb, if (present(Kd_Lay)) then do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (dt*Kd_lay(i,j,k)) + dtKd(i,k) = GV%Z_to_H**2 * (dt * (US%s_to_T * Kd_lay(i,j,k))) enddo ; enddo if (present(Kd_int)) then do K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt*Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H**2 * (dt * (US%s_to_T * Kd_int(i,j,K))) enddo ; enddo else do K=2,nz ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (0.5*dt*(Kd_lay(i,j,k-1) + Kd_lay(i,j,k))) + dtKd_int(i,K) = GV%Z_to_H**2 * (0.5 * dt & + * (US%s_to_T * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k)))) enddo ; enddo endif else ! Kd_int must be present, or there already would have been an error. do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (0.5*dt*(Kd_int(i,j,K)+Kd_int(i,j,K+1))) + dtKd(i,k) = GV%Z_to_H**2 * (0.5 * dt & + * (US%T_to_s * (Kd_int(i,j,K)+Kd_int(i,j,K+1)))) enddo ; enddo dO K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt*Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H**2 * (dt * (US%T_to_s * Kd_int(i,j,K))) enddo ; enddo endif @@ -2112,12 +2114,12 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "CORRECT_DENSITY", CS%correct_density, & - "If true, and USE_EOS is true, the layer densities are \n"//& - "restored toward their target values by the diapycnal \n"//& + "If true, and USE_EOS is true, the layer densities are "//& + "restored toward their target values by the diapycnal "//& "mixing, as described in Hallberg (MWR, 2000).", & default=.true.) call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & - "The maximum number of iterations that may be used to \n"//& + "The maximum number of iterations that may be used to "//& "calculate the interior diapycnal entrainment.", default=5) ! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] call get_param(param_file, mdl, "KD", Kd, fail_if_missing=.true.) diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 7ca06c6139..15f1116190 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -341,8 +341,8 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) ! write parameters to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "GEOTHERMAL_SCALE", scale, & - "The constant geothermal heat flux, a rescaling \n"//& - "factor for the heat flux read from GEOTHERMAL_FILE, or \n"//& + "The constant geothermal heat flux, a rescaling "//& + "factor for the heat flux read from GEOTHERMAL_FILE, or "//& "0 to disable the geothermal heating.", & units="W m-2 or various", default=0.0) CS%apply_geothermal = .not.(scale == 0.0) @@ -351,14 +351,14 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) call safe_alloc_ptr(CS%geo_heat, isd, ied, jsd, jed) ; CS%geo_heat(:,:) = 0.0 call get_param(param_file, mdl, "GEOTHERMAL_FILE", geo_file, & - "The file from which the geothermal heating is to be \n"//& + "The file from which the geothermal heating is to be "//& "read, or blank to use a constant heating rate.", default=" ") call get_param(param_file, mdl, "GEOTHERMAL_THICKNESS", CS%geothermal_thick, & "The thickness over which to apply geothermal heating.", & units="m", default=0.1) call get_param(param_file, mdl, "GEOTHERMAL_DRHO_DT_INPLACE", CS%dRcv_dT_inplace, & - "The value of drho_dT above which geothermal heating \n"//& - "simply heats water in place instead of moving it between \n"//& + "The value of drho_dT above which geothermal heating "//& + "simply heats water in place instead of moving it between "//& "isopycnal layers. This must be negative.", & units="kg m-3 K-1", default=-0.01) if (CS%dRcv_dT_inplace >= 0.0) call MOM_error(FATAL, "geothermal_init: "//& @@ -370,7 +370,7 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) filename = trim(inputdir)//trim(geo_file) call log_param(param_file, mdl, "INPUTDIR/GEOTHERMAL_FILE", filename) call get_param(param_file, mdl, "GEOTHERMAL_VARNAME", geotherm_var, & - "The name of the geothermal heating variable in \n"//& + "The name of the geothermal heating variable in "//& "GEOTHERMAL_FILE.", default="geo_heat") call MOM_read_data(filename, trim(geotherm_var), CS%geo_heat, G%Domain) do j=jsd,jed ; do i=isd,ied diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 111e8d44e2..bbc8250234 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -294,7 +294,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "MIN_ZBOT_ITIDES", min_zbot_itides, & - "Turn off internal tidal dissipation when the total \n"//& + "Turn off internal tidal dissipation when the total "//& "ocean depth is less than this value.", units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "UTIDE", utide, & @@ -308,7 +308,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed)) ; CS%TKE_itidal_coef(:,:) = 0.0 call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & - "A topographic wavenumber used with INT_TIDE_DISSIPATION. \n"//& + "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & units="m-1", default=8.e-4*atan(1.0)) @@ -316,16 +316,16 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "A scaling factor for the roughness amplitude with n"//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & - "The maximum internal tide energy source availble to mix \n"//& + "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & units="W m-2", default=1.0e3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & - "If true, read a file (given by TIDEAMP_FILE) containing \n"//& + "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) if (read_tideamp) then call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & - "The path to the file containing the spatially varying \n"//& + "The path to the file containing the spatially varying "//& "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) @@ -333,7 +333,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & - "The path to the file containing the sub-grid-scale \n"//& + "The path to the file containing the sub-grid-scale "//& "topographic roughness amplitude with INT_TIDE_DISSIPATION.", & fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index a92106444e..b5caeb2f53 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -289,8 +289,8 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif - f2 = 0.25*((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + f2 = 0.25 * US%s_to_T**2 * ((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = p_surf(i,j) ! ---------------------------------------------------- @@ -612,7 +612,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif - f2 = G%CoriolisBu(I,J)**2 + f2 = US%s_to_T**2 * G%CoriolisBu(I,J)**2 surface_pres = 0.0 ; if (associated(p_surf)) then surface_pres = 0.25 * ((p_surf(i,j) + p_surf(i+1,j+1)) + & (p_surf(i+1,j) + p_surf(i,j+1))) @@ -2021,86 +2021,86 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, & "Parameterization of shear-driven turbulence following Jackson, Hallberg and Legg, JPO 2008") call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_init, & - "If true, use the Jackson-Hallberg-Legg (JPO 2008) \n"//& + "If true, use the Jackson-Hallberg-Legg (JPO 2008) "//& "shear mixing parameterization.", default=.false.) call get_param(param_file, mdl, "VERTEX_SHEAR", CS%KS_at_vertex, & - "If true, do the calculations of the shear-driven mixing \n"//& + "If true, do the calculations of the shear-driven mixing "//& "at the cell vertices (i.e., the vorticity points).", & default=.false.) call get_param(param_file, mdl, "RINO_CRIT", CS%RiNo_crit, & "The critical Richardson number for shear mixing.", & units="nondim", default=0.25) call get_param(param_file, mdl, "SHEARMIX_RATE", CS%Shearmix_rate, & - "A nondimensional rate scale for shear-driven entrainment.\n"//& + "A nondimensional rate scale for shear-driven entrainment. "//& "Jackson et al find values in the range of 0.085-0.089.", & units="nondim", default=0.089) call get_param(param_file, mdl, "MAX_RINO_IT", CS%max_RiNo_it, & - "The maximum number of iterations that may be used to \n"//& + "The maximum number of iterations that may be used to "//& "estimate the Richardson number driven mixing.", & units="nondim", default=50) call get_param(param_file, mdl, "KD", KD_normal, default=1.0e-7, do_not_log=.true.) call get_param(param_file, mdl, "KD_KAPPA_SHEAR_0", CS%kappa_0, & - "The background diffusivity that is used to smooth the \n"//& - "density and shear profiles before solving for the \n"//& + "The background diffusivity that is used to smooth the "//& + "density and shear profiles before solving for the "//& "diffusivities. Defaults to value of KD.", & units="m2 s-1", default=KD_normal, scale=US%m_to_Z**2) call get_param(param_file, mdl, "FRI_CURVATURE", CS%FRi_curvature, & - "The nondimensional curvature of the function of the \n"//& - "Richardson number in the kappa source term in the \n"//& + "The nondimensional curvature of the function of the "//& + "Richardson number in the kappa source term in the "//& "Jackson et al. scheme.", units="nondim", default=-0.97) call get_param(param_file, mdl, "TKE_N_DECAY_CONST", CS%C_N, & - "The coefficient for the decay of TKE due to \n"//& - "stratification (i.e. proportional to N*tke). \n"//& + "The coefficient for the decay of TKE due to "//& + "stratification (i.e. proportional to N*tke). "//& "The values found by Jackson et al. are 0.24-0.28.", & units="nondim", default=0.24) ! call get_param(param_file, mdl, "LAYER_KAPPA_STAGGER", CS%layer_stagger, & ! default=.false.) call get_param(param_file, mdl, "TKE_SHEAR_DECAY_CONST", CS%C_S, & - "The coefficient for the decay of TKE due to shear (i.e. \n"//& - "proportional to |S|*tke). The values found by Jackson \n"//& + "The coefficient for the decay of TKE due to shear (i.e. "//& + "proportional to |S|*tke). The values found by Jackson "//& "et al. are 0.14-0.12.", units="nondim", default=0.14) call get_param(param_file, mdl, "KAPPA_BUOY_SCALE_COEF", CS%lambda, & - "The coefficient for the buoyancy length scale in the \n"//& - "kappa equation. The values found by Jackson et al. are \n"//& + "The coefficient for the buoyancy length scale in the "//& + "kappa equation. The values found by Jackson et al. are "//& "in the range of 0.81-0.86.", units="nondim", default=0.82) call get_param(param_file, mdl, "KAPPA_N_OVER_S_SCALE_COEF2", CS%lambda2_N_S, & - "The square of the ratio of the coefficients of the \n"//& - "buoyancy and shear scales in the diffusivity equation, \n"//& - "Set this to 0 (the default) to eliminate the shear scale. \n"//& + "The square of the ratio of the coefficients of the "//& + "buoyancy and shear scales in the diffusivity equation, "//& + "Set this to 0 (the default) to eliminate the shear scale. "//& "This is only used if USE_JACKSON_PARAM is true.", & units="nondim", default=0.0) call get_param(param_file, mdl, "KAPPA_SHEAR_TOL_ERR", CS%kappa_tol_err, & - "The fractional error in kappa that is tolerated. \n"//& - "Iteration stops when changes between subsequent \n"//& - "iterations are smaller than this everywhere in a \n"//& - "column. The peak diffusivities usually converge most \n"//& + "The fractional error in kappa that is tolerated. "//& + "Iteration stops when changes between subsequent "//& + "iterations are smaller than this everywhere in a "//& + "column. The peak diffusivities usually converge most "//& "rapidly, and have much smaller errors than this.", & units="nondim", default=0.1) call get_param(param_file, mdl, "TKE_BACKGROUND", CS%TKE_bg, & - "A background level of TKE used in the first iteration \n"//& + "A background level of TKE used in the first iteration "//& "of the kappa equation. TKE_BACKGROUND could be 0.", & units="m2 s-2", default=0.0) call get_param(param_file, mdl, "KAPPA_SHEAR_ELIM_MASSLESS", CS%eliminate_massless, & - "If true, massless layers are merged with neighboring \n"//& - "massive layers in this calculation. The default is \n"//& - "true and I can think of no good reason why it should \n"//& + "If true, massless layers are merged with neighboring "//& + "massive layers in this calculation. The default is "//& + "true and I can think of no good reason why it should "//& "be false. This is only used if USE_JACKSON_PARAM is true.", & default=.true.) call get_param(param_file, mdl, "MAX_KAPPA_SHEAR_IT", CS%max_KS_it, & - "The maximum number of iterations that may be used to \n"//& + "The maximum number of iterations that may be used to "//& "estimate the time-averaged diffusivity.", units="nondim", & default=13) call get_param(param_file, mdl, "PRANDTL_TURB", CS%Prandtl_turb, & - "The turbulent Prandtl number applied to shear \n"//& + "The turbulent Prandtl number applied to shear "//& "instability.", units="nondim", default=1.0, do_not_log=.true.) call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & - "A negligibly small velocity magnitude below which velocity \n"//& - "components are set to 0. A reasonable value might be \n"//& - "1e-30 m/s, which is less than an Angstrom divided by \n"//& + "A negligibly small velocity magnitude below which velocity "//& + "components are set to 0. A reasonable value might be "//& + "1e-30 m/s, which is less than an Angstrom divided by "//& "the age of the universe.", units="m s-1", default=0.0) call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", CS%debug, & "If true, write debugging data for the kappa-shear code. \n"//& - "Caution: this option is _very_ verbose and should only \n"//& + "Caution: this option is _very_ verbose and should only "//& "be used in single-column mode!", & default=.false., debuggingParam=.true.) @@ -2112,7 +2112,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%nkml = 1 if (GV%nkml>0) then call get_param(param_file, mdl, "KAPPA_SHEAR_MERGE_ML",merge_mixedlayer, & - "If true, combine the mixed layers together before \n"//& + "If true, combine the mixed layers together before "//& "solving the kappa-shear equations.", default=.true.) if (merge_mixedlayer) CS%nkml = GV%nkml endif @@ -2160,7 +2160,7 @@ logical function kappa_shear_at_vertex(param_file) kappa_shear_at_vertex = .false. if (do_Kappa_Shear) & call get_param(param_file, mdl, "VERTEX_SHEAR", kappa_shear_at_vertex, & - "If true, do the calculations of the shear-driven mixing \n"//& + "If true, do the calculations of the shear-driven mixing "//& "at the cell vertices (i.e., the vorticity points).", & default=.false., do_not_log=.true.) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index e89ded7e13..75aa447e15 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -477,15 +477,15 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) ! parameters for CHL_A routines call get_param(param_file, mdl, "VAR_PEN_SW", CS%var_pen_sw, & - "If true, use one of the CHL_A schemes specified by \n"//& - "OPACITY_SCHEME to determine the e-folding depth of \n"//& + "If true, use one of the CHL_A schemes specified by "//& + "OPACITY_SCHEME to determine the e-folding depth of "//& "incoming short wave radiation.", default=.false.) CS%opacity_scheme = NO_SCHEME ; scheme_string = '' if (CS%var_pen_sw) then call get_param(param_file, mdl, "OPACITY_SCHEME", tmpstr, & - "This character string specifies how chlorophyll \n"//& - "concentrations are translated into opacities. Currently \n"//& + "This character string specifies how chlorophyll "//& + "concentrations are translated into opacities. Currently "//& "valid options include:\n"//& " \t\t MANIZZA_05 - Use Manizza et al., GRL, 2005. \n"//& " \t\t MOREL_88 - Use Morel, JGR, 1988.", & @@ -516,8 +516,8 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") call get_param(param_file, mdl, "CHL_FILE", chl_file, & - "CHL_FILE is the file containing chl_a concentrations in \n"//& - "the variable CHL_A. It is used when VAR_PEN_SW and \n"//& + "CHL_FILE is the file containing chl_a concentrations in "//& + "the variable CHL_A. It is used when VAR_PEN_SW and "//& "CHL_FROM_FILE are true.", fail_if_missing=.true.) filename = trim(slasher(inputdir))//trim(chl_file) call log_param(param_file, mdl, "INPUTDIR/CHL_FILE", filename) @@ -527,12 +527,12 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) endif call get_param(param_file, mdl, "BLUE_FRAC_SW", CS%blue_frac, & - "The fraction of the penetrating shortwave radiation \n"//& + "The fraction of the penetrating shortwave radiation "//& "that is in the blue band.", default=0.5, units="nondim") else call get_param(param_file, mdl, "EXP_OPACITY_SCHEME", tmpstr, & - "This character string specifies which exponential \n"//& - "opacity scheme to utilize. Currently \n"//& + "This character string specifies which exponential "//& + "opacity scheme to utilize. Currently "//& "valid options include:\n"//& " \t\t SINGLE_EXP - Single Exponent decay. \n"//& " \t\t DOUBLE_EXP - Double Exponent decay.", & @@ -548,17 +548,17 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) call MOM_mesg('opacity_init: opacity scheme set to "'//trim(tmpstr)//'".', 5) endif call get_param(param_file, mdl, "PEN_SW_SCALE", CS%pen_sw_scale, & - "The vertical absorption e-folding depth of the \n"//& + "The vertical absorption e-folding depth of the "//& "penetrating shortwave radiation.", units="m", default=0.0) !BGR/ Added for opacity_scheme==double_exp read in 2nd exp-decay and fraction if (CS%Opacity_scheme == DOUBLE_EXP ) then call get_param(param_file, mdl, "PEN_SW_SCALE_2ND", CS%pen_sw_scale_2nd, & - "The (2nd) vertical absorption e-folding depth of the \n"//& - "penetrating shortwave radiation \n"//& + "The (2nd) vertical absorption e-folding depth of the "//& + "penetrating shortwave radiation "//& "(use if SW_EXP_MODE==double.)",& units="m", default=0.0) call get_param(param_file, mdl, "SW_1ST_EXP_RATIO", CS%sw_1st_exp_ratio, & - "The fraction of 1st vertical absorption e-folding depth \n"//& + "The fraction of 1st vertical absorption e-folding depth "//& "penetrating shortwave radiation if SW_EXP_MODE==double.",& units="m", default=0.0) elseif (CS%OPACITY_SCHEME == Single_Exp) then @@ -567,7 +567,7 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) CS%sw_1st_exp_ratio = 1.0 endif call get_param(param_file, mdl, "PEN_SW_FRAC", CS%pen_sw_frac, & - "The fraction of the shortwave radiation that penetrates \n"//& + "The fraction of the shortwave radiation that penetrates "//& "below the surface.", units="nondim", default=0.0) endif @@ -606,7 +606,7 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) endif call get_param(param_file, mdl, "OPACITY_LAND_VALUE", CS%opacity_land_value, & - "The value to use for opacity over land. The default is \n"//& + "The value to use for opacity over land. The default is "//& "10 m-1 - a value for muddy water.", units="m-1", default=10.0) if (.not.associated(optics%opacity_band)) & diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 989b2f0154..cca2d9f94e 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -899,23 +899,23 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "REGULARIZE_SURFACE_LAYERS", CS%regularize_surface_layers, & - "If defined, vertically restructure the near-surface \n"//& - "layers when they have too much lateral variations to \n"//& + "If defined, vertically restructure the near-surface "//& + "layers when they have too much lateral variations to "//& "allow for sensible lateral barotropic transports.", & default=.false.) if (CS%regularize_surface_layers) then call get_param(param_file, mdl, "REGULARIZE_SURFACE_DETRAIN", CS%reg_sfc_detrain, & - "If true, allow the buffer layers to detrain into the \n"//& - "interior as a part of the restructuring when \n"//& + "If true, allow the buffer layers to detrain into the "//& + "interior as a part of the restructuring when "//& "REGULARIZE_SURFACE_LAYERS is true.", default=.true.) endif call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & - "The minimum mixed layer depth if the mixed layer depth \n"//& + "The minimum mixed layer depth if the mixed layer depth "//& "is determined dynamically.", units="m", default=0.0, scale=GV%m_to_H) call get_param(param_file, mdl, "REG_SFC_DEFICIT_TOLERANCE", CS%h_def_tol1, & - "The value of the relative thickness deficit at which \n"//& - "to start modifying the layer structure when \n"//& + "The value of the relative thickness deficit at which "//& + "to start modifying the layer structure when "//& "REGULARIZE_SURFACE_LAYERS is true.", units="nondim", & default=0.5) CS%h_def_tol2 = 0.2 + 0.8*CS%h_def_tol1 @@ -927,9 +927,8 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) ! call get_param(param_file, mdl, "DEBUG_CONSERVATION", CS%debug, & ! "If true, monitor conservation and extrema.", default=.false.) - call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", & - CS%allow_clocks_in_omp_loops, & - "If true, clocks can be called from inside loops that can \n"//& + call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", CS%allow_clocks_in_omp_loops, & + "If true, clocks can be called from inside loops that can "//& "be threaded. To run with multiple threads, set to False.", & default=.true.) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index e4214c8d16..d450ca37ab 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -75,35 +75,35 @@ module MOM_set_diffusivity real :: cdrag !< quadratic drag coefficient [nondim] real :: IMax_decay !< inverse of a maximum decay scale for !! bottom-drag driven turbulence [Z-1 ~> m-1]. - real :: Kv !< The interior vertical viscosity [Z2 s-1 ~> m2 s-1]. - real :: Kd !< interior diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. - real :: Kd_min !< minimum diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. - real :: Kd_max !< maximum increment for diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. + real :: Kv !< The interior vertical viscosity [Z2 T-1 ~> m2 s-1]. + real :: Kd !< interior diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_min !< minimum diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_max !< maximum increment for diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. !! Set to a negative value to have no limit. real :: Kd_add !< uniform diffusivity added everywhere without - !! filtering or scaling [Z2 s-1 ~> m2 s-1]. - real :: Kdml !< mixed layer diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. + !! filtering or scaling [Z2 T-1 ~> m2 s-1]. + real :: Kdml !< mixed layer diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. !! when bulkmixedlayer==.false. real :: Hmix !< mixed layer thickness [meter] when BULKMIXEDLAYER==.false. type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing logical :: limit_dissipation !< If enabled, dissipation is limited to be larger !! than the following: - real :: dissip_min !< Minimum dissipation [Z2 m-2 W m-3 ~> W m-3] - real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [Z2 m-2 W m-3 ~> W m-3] - real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [Z2 m-2 W m-3 s ~> J m-3] - real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [Z2 m-2 W m-3 s2 ~> J s m-3] - real :: dissip_Kd_min !< Minimum Kd [Z2 s-1 ~> m2 s-1], with dissipation Rho0*Kd_min*N^2 + real :: dissip_min !< Minimum dissipation [kg Z2 m-3 T-3 ~> W m-3] + real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [kg Z2 m-3 T-3 ~> W m-3] + real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [kg Z2 m-3 T-2 ~> J m-3] + real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [kg Z2 m-3 T-1 ~> J s m-3] + real :: dissip_Kd_min !< Minimum Kd [Z2 T-1 ~> m2 s-1], with dissipation Rho0*Kd_min*N^2 real :: TKE_itide_max !< maximum internal tide conversion [W m-2] !! available to mix above the BBL - real :: omega !< Earth's rotation frequency [s-1] + real :: omega !< Earth's rotation frequency [T-1 ~> s-1] logical :: ML_radiation !< allow a fraction of TKE available from wind work !! to penetrate below mixed layer base with a vertical !! decay scale determined by the minimum of !! (1) The depth of the mixed layer, or !! (2) An Ekman length scale. - !! Energy availble to drive mixing below the mixed layer is + !! Energy available to drive mixing below the mixed layer is !! given by E = ML_RAD_COEFF*MSTAR*USTAR**3. Optionally, if !! ML_rad_TKE_decay is true, this is further reduced by a factor !! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is @@ -112,7 +112,7 @@ module MOM_set_diffusivity !! where N2 is the squared buoyancy frequency [s-2] and OMEGA2 !! is the rotation rate of the earth squared. real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence - !! radiated from the base of the mixed layer [Z2 s-1 ~> m2 s-1]. + !! radiated from the base of the mixed layer [Z2 T-1 ~> m2 s-1]. real :: ML_rad_efold_coeff !< non-dim coefficient to scale penetration depth real :: ML_rad_coeff !< coefficient, which scales MSTAR*USTAR^3 to !! obtain energy available for mixing below @@ -121,7 +121,7 @@ module MOM_set_diffusivity !! to ML_rad as applied to the other surface !! sources of TKE in the mixed layer code. real :: ustar_min !< A minimum value of ustar to avoid numerical - !! problems [Z s-1 ~> m s-1]. If the value is small enough, + !! problems [Z T-1 ~> m s-1]. If the value is small enough, !! this parameter should not affect the solution. real :: TKE_decay !< ratio of natural Ekman depth to TKE decay scale [nondim] real :: mstar !< ratio of friction velocity cubed to @@ -144,8 +144,8 @@ module MOM_set_diffusivity logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that !! does not rely on a layer-formulation. real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering - real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [Z2 s-1 ~> m2 s-1] - real :: Kv_molecular !< molecular visc for double diff convect [Z2 s-1 ~> m2 s-1] + real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [Z2 T-1 ~> m2 s-1] + real :: Kv_molecular !< molecular visc for double diff convect [Z2 T-1 ~> m2 s-1] character(len=200) :: inputdir !< The directory in which input files are found type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() !< Control structure for a child module @@ -170,17 +170,17 @@ module MOM_set_diffusivity !> This structure has memory for used in calculating diagnostics of diffusivity type diffusivity_diags real, pointer, dimension(:,:,:) :: & - N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [s-2] - Kd_user => NULL(), & !< user-added diffusivity at interfaces [Z2 s-1 ~> m2 s-1] - Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [Z2 s-1 ~> m2 s-1] - Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [W m-2] - maxTKE => NULL(), & !< energy required to entrain to h_max [m3 s-3] - KT_extra => NULL(), & !< double diffusion diffusivity for temp [Z2 s-1 ~> m2 s-1]. - KS_extra => NULL() !< double diffusion diffusivity for saln [Z2 s-1 ~> m2 s-1]. + N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] + Kd_user => NULL(), & !< user-added diffusivity at interfaces [Z2 T-1 ~> m2 s-1] + Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [Z2 T-1 ~> m2 s-1] + Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [kg Z3 m-3 T-3 ~> W m-2] + maxTKE => NULL(), & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] + KT_extra => NULL(), & !< double diffusion diffusivity for temp [Z2 T-1 ~> m2 s-1]. + KS_extra => NULL() !< double diffusion diffusivity for saln [Z2 T-1 ~> m2 s-1]. real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE !! dissipated within a layer and Kd in that layer - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] end type diffusivity_diags @@ -225,13 +225,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & real, intent(in) :: dt !< Time increment [s]. type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 s-1 ~> m2 s-1]. + intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(out) :: Kd_int !< Diapycnal diffusivity at each interface [Z2 s-1 ~> m2 s-1]. + optional, intent(out) :: Kd_int !< Diapycnal diffusivity at each interface [Z2 T-1 ~> m2 s-1]. ! local variables real, dimension(SZI_(G)) :: & - N2_bot ! bottom squared buoyancy frequency [s-2] + N2_bot ! bottom squared buoyancy frequency [T-2 ~> s-2] type(diffusivity_diags) :: dd ! structure w/ arrays of pointers to avail diags @@ -243,21 +243,21 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! after full convective adjustment. real, dimension(SZI_(G),SZK_(G)) :: & - N2_lay, & !< squared buoyancy frequency associated with layers [s-2] - maxTKE, & !< energy required to entrain to h_max [m3 s-3] + N2_lay, & !< squared buoyancy frequency associated with layers [T-2 ~> s-2] + maxTKE, & !< energy required to entrain to h_max [m3 T-3] TKE_to_Kd !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between - !< TKE dissipated within a layer and Kd in that layer, in - !< m2 s-1 / m3 s-3 = [s2 m-1]. + !< TKE dissipated within a layer and Kd in that layer + !< [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)+1) :: & - N2_int, & !< squared buoyancy frequency associated at interfaces [s-2] + N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] dRho_int, & !< locally ref potential density difference across interfaces [kg m-3] - KT_extra, & !< double difusion diffusivity of temperature [Z2 s-1 ~> m2 s-1] - KS_extra !< double difusion diffusivity of salinity [Z2 s-1 ~> m2 s-1] + KT_extra, & !< double difusion diffusivity of temperature [Z2 T-1 ~> m2 s-1] + KS_extra !< double difusion diffusivity of salinity [Z2 T-1 ~> m2 s-1] real :: I_Rho0 ! inverse of Boussinesq density [m3 kg-1] - real :: dissip ! local variable for dissipation calculations [Z2 W m-5 ~> W m-3] - real :: Omega2 ! squared absolute rotation rate [s-2] + real :: dissip ! local variable for dissipation calculations [Z2 kg m-3 T-3 ~> W m-3] + real :: Omega2 ! squared absolute rotation rate [T-2 ~> s-2] logical :: use_EOS ! If true, compute density from T/S using equation of state. type(p3d) :: z_ptrs(6) ! pointers to diagns to be interpolated into depth space @@ -270,8 +270,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & integer :: i, j, k, is, ie, js, je, nz integer :: isd, ied, jsd, jed - real :: kappa_fill ! diffusivity used to fill massless layers - real :: dt_fill ! timestep used to fill massless layers + real :: kappa_fill ! diffusivity used to fill massless layers [Z2 T-1 ~> m2 s-1] + real :: dt_fill ! timestep used to fill massless layers [T ~> s] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -281,10 +281,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (.not.associated(CS)) call MOM_error(FATAL,"set_diffusivity: "//& "Module must be initialized before it is used.") - I_Rho0 = 1.0/GV%Rho0 - kappa_fill = 1.e-3*US%m_to_Z**2 !### Dimensional constant [m2 s-1]. - dt_fill = 7200. !### Dimensionalconstant [s]. - Omega2 = CS%Omega*CS%Omega + I_Rho0 = 1.0 / GV%Rho0 + ! ### Dimensional parameters + kappa_fill = 1.e-3 * US%m2_s_to_Z2_T + dt_fill = 7200. * US%s_to_T + Omega2 = CS%omega * CS%omega use_EOS = associated(tv%eqn_of_state) @@ -297,7 +298,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! If nothing else is specified, this will be the value used. Kd_lay(:,:,:) = CS%Kd Kd_int(:,:,:) = CS%Kd - if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = US%s_to_T * CS%Kv ! Set up arrays for diagnostics. @@ -352,7 +353,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then call full_convection(G, GV, h, tv, T_adj, S_adj, fluxes%p_surf, & - GV%Z_to_H**2*kappa_fill*dt_fill, halo=1) + (GV%Z_to_H**2)*kappa_fill*dt_fill, halo=1) call calc_kappa_shear_vertex(u, v, h, T_adj, S_adj, tv, fluxes%p_surf, visc%Kd_shear, & visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) @@ -394,7 +395,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & call sfc_bkgnd_mixing(G, US, CS%bkgnd_mixing_csp) !$OMP parallel do default(shared) private(dRho_int, N2_lay, N2_int, N2_bot, KT_extra, & - !$OMP KS_extra, TKE_to_Kd,maxTKE, dissip, kb) + !$OMP KS_extra, TKE_to_Kd, maxTKE, dissip, kb) do j=js,je ! Set up variables related to the stratification. @@ -412,14 +413,14 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & call double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, KT_extra, KS_extra) do K=2,nz ; do i=is,ie if (KS_extra(i,K) > KT_extra(i,K)) then ! salt fingering - Kd_lay(i,j,k-1) = Kd_lay(i,j,k-1) + 0.5*KT_extra(i,K) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*KT_extra(i,K) - visc%Kd_extra_S(i,j,k) = (KS_extra(i,K) - KT_extra(i,K)) + Kd_lay(i,j,k-1) = Kd_lay(i,j,k-1) + 0.5 * KT_extra(i,K) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * KT_extra(i,K) + visc%Kd_extra_S(i,j,k) = US%s_to_T * (KS_extra(i,K) - KT_extra(i,K)) visc%Kd_extra_T(i,j,k) = 0.0 elseif (KT_extra(i,K) > 0.0) then ! double-diffusive convection - Kd_lay(i,j,k-1) = Kd_lay(i,j,k-1) + 0.5**KS_extra(i,K) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5**KS_extra(i,K) - visc%Kd_extra_T(i,j,k) = (KT_extra(i,K) - KS_extra(i,K)) + Kd_lay(i,j,k-1) = Kd_lay(i,j,k-1) + 0.5 * KS_extra(i,K) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * KS_extra(i,K) + visc%Kd_extra_T(i,j,k) = US%s_to_T * (KT_extra(i,K) - KS_extra(i,K)) visc%Kd_extra_S(i,j,k) = 0.0 else ! There is no double diffusion at this interface. visc%Kd_extra_T(i,j,k) = 0.0 @@ -447,15 +448,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%useKappaShear .or. CS%use_CVMix_shear) then if (present(Kd_int)) then do K=2,nz ; do i=is,ie - Kd_int(i,j,K) = visc%Kd_shear(i,j,K) + 0.5*(Kd_lay(i,j,k-1) + Kd_lay(i,j,k)) + Kd_int(i,j,K) = (US%T_to_s * visc%Kd_shear(i,j,K)) + 0.5 * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k)) enddo ; enddo do i=is,ie - Kd_int(i,j,1) = visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. + Kd_int(i,j,1) = US%T_to_s * visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. Kd_int(i,j,nz+1) = 0.0 enddo endif do k=1,nz ; do i=is,ie - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*(visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%T_to_s * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) enddo ; enddo else if (present(Kd_int)) then @@ -463,12 +464,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & Kd_int(i,j,1) = Kd_lay(i,j,1) ; Kd_int(i,j,nz+1) = 0.0 enddo do K=2,nz ; do i=is,ie - Kd_int(i,j,K) = 0.5*(Kd_lay(i,j,k-1) + Kd_lay(i,j,k)) + Kd_int(i,j,K) = 0.5 * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k)) enddo ; enddo endif endif - call find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, TKE_to_Kd, & + call find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, (US%s_to_T)*dt, G, GV, US, CS, TKE_to_Kd, & maxTKE, kb) if (associated(dd%maxTKE)) then ; do k=1,nz ; do i=is,ie dd%maxTKE(i,j,k) = maxTKE(i,k) @@ -506,30 +507,31 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & do k=2,nz-1 ; do i=is,ie dissip = max( CS%dissip_min, & ! Const. floor on dissip. CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_lay(i,k)), & ! Floor aka Gargett - CS%dissip_N2 * N2_lay(i,k) ) ! Floor of Kd_min*rho0/F_Ri - Kd_lay(i,j,k) = max( Kd_lay(i,j,k) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2))) ) + CS%dissip_N2 * N2_lay(i,k)) ! Floor of Kd_min*rho0/F_Ri + Kd_lay(i,j,k) = max(Kd_lay(i,j,k) , & ! Apply floor to Kd + dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2)))) enddo ; enddo if (present(Kd_int)) then ; do K=2,nz ; do i=is,ie dissip = max( CS%dissip_min, & ! Const. floor on dissip. CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_int(i,K)), & ! Floor aka Gargett - CS%dissip_N2 * N2_int(i,K) ) ! Floor of Kd_min*rho0/F_Ri - Kd_int(i,j,K) = max( Kd_int(i,j,K) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_int(i,K) + Omega2))) ) + CS%dissip_N2 * N2_int(i,K)) ! Floor of Kd_min*rho0/F_Ri + Kd_int(i,j,K) = max(Kd_int(i,j,K) , & ! Apply floor to Kd + dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_int(i,K) + Omega2)))) enddo ; enddo ; endif endif if (associated(dd%Kd_work)) then do k=1,nz ; do i=is,ie - dd%Kd_Work(i,j,k) = GV%Rho0 * US%Z_to_m**3*Kd_lay(i,j,k) * N2_lay(i,k) * & + dd%Kd_Work(i,j,k) = GV%Rho0 * Kd_lay(i,j,k) * N2_lay(i,k) * & GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 enddo ; enddo endif enddo ! j-loop if (CS%debug) then - call hchksum(Kd_lay ,"Kd_lay", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(Kd_lay ,"Kd_lay", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=US%Z_to_m**2) @@ -670,17 +672,17 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: dRho_int !< Change in locally referenced potential density !! across each interface [kg m-3]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the - !! layers [s-2]. + !! layers [T-2 ~> s-2]. integer, intent(in) :: j !< j-index of row to work on - real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(SZI_(G),SZK_(G)), intent(out) :: TKE_to_Kd !< The conversion rate between the TKE - !! TKE dissipated within a layer and the + real, dimension(SZI_(G),SZK_(G)), intent(out) :: TKE_to_Kd !< The conversion rate between the + !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)), intent(out) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [m3 s-3] + !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] integer, dimension(SZI_(G)), intent(out) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer. ! Local variables @@ -709,33 +711,38 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! undergo before entraining all fluid in the layers ! above or below [Z ~> m]. real :: dRho_lay ! density change across a layer [kg m-3] - real :: Omega2 ! rotation rate squared [s-2] - real :: G_Rho0 ! gravitation accel divided by Bouss ref density [m4 s-2 kg-1] + real :: Omega2 ! rotation rate squared [T-2 ~> s-2] + real :: G_Rho0 ! gravitation accel divided by Bouss ref density [m4 T-2 kg-1 -> m4 s-2 kg-1] + real :: G_IRho0 ! ### Alternate calculation of G_Rho0 for reproducibility real :: I_Rho0 ! inverse of Boussinesq reference density [m3 kg-1] - real :: I_dt ! 1/dt [s-1] + real :: I_dt ! 1/dt [T-1] real :: H_neglect ! negligibly small thickness [H ~> m or kg m-2] - real :: hN2pO2 ! h (N^2 + Omega^2), in [m3 s-2 Z-2 ~> m s-2]. + real :: hN2pO2 ! h (N^2 + Omega^2), in [m3 T-2 Z-2 ~> m s-2]. logical :: do_i(SZI_(G)) integer :: i, k, is, ie, nz, i_rem, kmb, kb_min is = G%isc ; ie = G%iec ; nz = G%ke - I_dt = 1.0/dt - Omega2 = CS%Omega**2 - G_Rho0 = (GV%g_Earth*US%m_to_Z**2) / GV%Rho0 + I_dt = 1.0 / dt + Omega2 = CS%omega**2 H_neglect = GV%H_subroundoff - I_Rho0 = 1.0/GV%Rho0 + ! ### G_Rho0 and G_IRho0 are mathematically identical but give different + ! numerical values. We compute both values for now, but they should be + ! consolidated at some point. + G_Rho0 = (GV%g_Earth * US%m_to_Z**2 * US%T_to_s**2) / GV%Rho0 + I_Rho0 = 1.0 / GV%Rho0 + G_IRho0 = (GV%g_Earth * US%m_to_Z**2 * US%T_to_s**2) * I_Rho0 ! Simple but coordinate-independent estimate of Kd/TKE if (CS%simple_TKE_to_Kd) then do k=1,nz ; do i=is,ie - hN2pO2 = US%Z_to_m**3 * ( GV%H_to_Z * h(i,j,k) ) * ( N2_lay(i,k) + Omega2 ) ! Units of m3 Z-2 s-2. + hN2pO2 = (GV%H_to_Z * h(i,j,k)) * (N2_lay(i,k) + Omega2) ! Units of Z T-2. if (hN2pO2>0.) then - TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of Z2 s2 m-3. + TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of T2 Z-1. else; TKE_to_Kd(i,k) = 0.; endif ! The maximum TKE conversion we allow is really a statement ! about the upper diffusivity we allow. Kd_max must be set. - maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of m3 s-3. + maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of Z3 T-3. enddo ; enddo kb(is:ie) = -1 ! kb should not be used by any code in non-layered mode -AJA return @@ -830,7 +837,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & enddo do k=2,kmb ; do i=is,ie maxTKE(i,k) = 0.0 - TKE_to_Kd(i,k) = US%m_to_Z**3 / ((N2_lay(i,k) + Omega2) * & + TKE_to_Kd(i,k) = 1.0 / ((N2_lay(i,k) + Omega2) * & (GV%H_to_Z*(h(i,j,k) + H_neglect))) enddo ; enddo do k=kmb+1,kb_min-1 ; do i=is,ie @@ -851,11 +858,11 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! dRho_int should already be non-negative, so the max is redundant? dh_max = maxEnt(i,k) * (1.0 + dsp1_ds(i,k)) dRho_lay = 0.5 * max(dRho_int(i,K) + dRho_int(i,K+1), 0.0) - maxTKE(i,k) = I_dt*US%Z_to_m * ((GV%g_Earth * I_Rho0) * & + maxTKE(i,k) = I_dt * (G_IRho0 * & (0.5*max(dRho_int(i,K+1) + dsp1_ds(i,k)*dRho_int(i,K), 0.0))) * & - ((GV%H_to_Z*h(i,j,k) + dh_max) * maxEnt(i,k)) - TKE_to_Kd(i,k) = US%m_to_Z**3 / (G_Rho0 * dRho_lay + & - CS%Omega**2 * GV%H_to_Z*(h(i,j,k) + H_neglect)) + ((GV%H_to_Z*h(i,j,k) + dh_max) * maxEnt(i,k)) + TKE_to_Kd(i,k) = 1.0 / (G_Rho0 * dRho_lay + & + CS%omega**2 * GV%H_to_Z*(h(i,j,k) + H_neglect)) endif enddo ; enddo @@ -884,10 +891,10 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & intent(out) :: dRho_int !< Change in locally referenced potential density !! across each interface [kg m-3]. real, dimension(SZI_(G),SZK_(G)+1), & - intent(out) :: N2_int !< The squared buoyancy frequency at the interfaces [s-2]. + intent(out) :: N2_int !< The squared buoyancy frequency at the interfaces [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(G)), & - intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [s-2]. - real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [s-2]. + intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. ! Local variables real, dimension(SZI_(G),SZK_(G)+1) :: & dRho_int_unfilt, & ! unfiltered density differences across interfaces @@ -906,14 +913,14 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real :: Rml_base ! density of the deepest variable density layer real :: dz_int ! thickness associated with an interface [Z ~> m]. real :: G_Rho0 ! gravitation acceleration divided by Bouss reference density - ! times some unit conversion factors [Z m3 s-2 kg-1 ~> m4 s-2 kg-1]. + ! times some unit conversion factors [Z m3 T-2 kg-1 ~> m4 s-2 kg-1]. real :: H_neglect ! negligibly small thickness, in the same units as h. logical :: do_i(SZI_(G)), do_any integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke - G_Rho0 = (GV%g_Earth*US%m_to_Z**2) / GV%Rho0 + G_Rho0 = (GV%g_Earth*US%m_to_Z**2 * US%T_to_s**2) / GV%Rho0 H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -1056,10 +1063,10 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: Kd_T_dd !< Interface double diffusion diapycnal - !! diffusivity for temp [Z2 s-1 ~> m2 s-1]. + !! diffusivity for temp [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal - !! diffusivity for saln [Z2 s-1 ~> m2 s-1]. + !! diffusivity for saln [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G)) :: & dRho_dT, & ! partial derivatives of density wrt temp [kg m-3 degC-1] @@ -1073,20 +1080,15 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real :: Rrho ! vertical density ratio [nondim] real :: diff_dd ! factor for double-diffusion [nondim] - real :: Kd_dd ! The dominant double diffusive diffusivity [Z2 s-1 ~> m2 s-1] + real :: Kd_dd ! The dominant double diffusive diffusivity [Z2 T-1 ~> m2 s-1] real :: prandtl ! flux ratio for diffusive convection regime real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] - real :: dsfmax ! max diffusivity in case of salt fingering [Z2 s-1 ~> m2 s-1] - real :: Kv_molecular ! molecular viscosity [Z2 s-1 ~> m2 s-1] integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke if (associated(tv%eqn_of_state)) then - dsfmax = US%m_to_Z**2 * 1.e-4 ! max salt fingering diffusivity rescaled to [Z2 s-1 ~> m2 s-1] - Kv_molecular = US%m_to_Z**2 * 1.5e-6 ! molecular viscosity rescaled to [Z2 s-1 ~> m2 s-1] - do i=is,ie pres(i) = 0.0 ; Kd_T_dd(i,1) = 0.0 ; Kd_S_dd(i,1) = 0.0 Kd_T_dd(i,nz+1) = 0.0 ; Kd_S_dd(i,nz+1) = 0.0 @@ -1107,16 +1109,16 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case Rrho = min(alpha_dT / beta_dS, Rrho0) diff_dd = 1.0 - ((RRho-1.0)/(RRho0-1.0)) - Kd_dd = dsfmax * diff_dd*diff_dd*diff_dd - Kd_T_dd(i,K) = 0.7*Kd_dd + Kd_dd = CS%Max_salt_diff_salt_fingers * diff_dd*diff_dd*diff_dd + Kd_T_dd(i,K) = 0.7 * Kd_dd Kd_S_dd(i,K) = Kd_dd elseif ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then ! diffusive convection Rrho = alpha_dT / beta_dS - Kd_dd = Kv_molecular * 0.909*exp(4.6*exp(-0.54*(1/Rrho-1))) + Kd_dd = CS%Kv_molecular * 0.909 * exp(4.6 * exp(-0.54 * (1/Rrho - 1))) prandtl = 0.15*Rrho if (Rrho > 0.5) prandtl = (1.85-0.85/Rrho)*Rrho Kd_T_dd(i,K) = Kd_dd - Kd_S_dd(i,K) = prandtl*Kd_dd + Kd_S_dd(i,K) = prandtl * Kd_dd else Kd_T_dd(i,K) = 0.0 ; Kd_S_dd(i,K) = 0.0 endif @@ -1148,19 +1150,19 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)), intent(in) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [m3 s-3] + !! to its maximum-realizable thickness [m3 T-3 ~> m3 s-3] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers, - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, - !! [Z2 s-1 ~> m2 s-1]. - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1]. ! This routine adds diffusion sustained by flow energy extracted by bottom drag. @@ -1174,19 +1176,19 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! the local ustar, times R0_g [kg m-2] Rho_top, & ! density at top of the BBL [kg m-3] TKE, & ! turbulent kinetic energy available to drive - ! bottom-boundary layer mixing in a layer [m3 s-3] + ! bottom-boundary layer mixing in a layer [Z3 T-3 ~> m3 s-3] I2decay ! inverse of twice the TKE decay scale [Z-1 ~> m-1]. - real :: TKE_to_layer ! TKE used to drive mixing in a layer [m3 s-3] - real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [m3 s-3] - real :: TKE_here ! TKE that goes into mixing in this layer [m3 s-3] + real :: TKE_to_layer ! TKE used to drive mixing in a layer [Z3 T-3 ~> m3 s-3] + real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [Z3 T-3 ~> m3 s-3] + real :: TKE_here ! TKE that goes into mixing in this layer [Z3 T-3 ~> m3 s-3] real :: dRl, dRbot ! temporaries holding density differences [kg m-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar_h ! value of ustar at a thickness point [Z s-1 ~> m s-1]. - real :: absf ! average absolute Coriolis parameter around a thickness point [s-1] - real :: R0_g ! Rho0 / G_Earth [kg s2 Z-1 m-4 ~> kg s2 m-5] + real :: ustar_h ! value of ustar at a thickness point [Z T-1 ~> m s-1]. + real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] + real :: R0_g ! Rho0 / G_Earth [kg T2 Z-1 m-4 ~> kg s2 m-5] real :: I_rho0 ! 1 / RHO0 [m3 kg-1] - real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [Z2 s-1 ~> m2 s-1]. + real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [Z2 T-1 ~> m2 s-1]. logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this ! extracted energy also drives diapycnal mixing. @@ -1206,7 +1208,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) Rayleigh_drag = .true. I_Rho0 = 1.0/GV%Rho0 - R0_g = GV%Rho0 / (US%m_to_Z**2*GV%g_Earth) + R0_g = GV%Rho0 / (US%m_to_Z**2 * US%T_to_s**2 * GV%g_Earth) do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo @@ -1216,11 +1218,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! Any turbulence that makes it into the mixed layers is assumed ! to be relatively small and is discarded. do i=is,ie - ustar_h = visc%ustar_BBL(i,j) + ustar_h = US%T_to_s * visc%ustar_BBL(i,j) if (associated(fluxes%ustar_tidal)) & - ustar_h = ustar_h + US%m_to_Z*fluxes%ustar_tidal(i,j) - absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) + ustar_h = ustar_h + (US%m_to_Z * US%T_to_s * fluxes%ustar_tidal(i,j)) + absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) if ((ustar_h > 0.0) .and. (absf > 0.5*CS%IMax_decay*ustar_h)) then I2decay(i) = absf / ustar_h else @@ -1228,12 +1230,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! If ustar_h = 0, this is land so this value doesn't matter. I2decay(i) = 0.5*CS%IMax_decay endif - TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * & - exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & + TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & - TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * I_Rho0 * & + TKE(i) = TKE(i) + (US%T_to_s**3 * US%m_to_Z**3 * fluxes%TKE_tidal(i,j)) * I_Rho0 * & (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz)))) ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following @@ -1284,13 +1285,14 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & TKE_to_layer = TKE(i) else dRl = Rint(K+1) - Rint(K) ; dRbot = Rint(K+1) - Rho_top(i) - TKE_to_layer = TKE(i) * dRl * (3.0*dRbot*(Rint(K) - Rho_top(i)) +& - dRl**2) / dRbot**3 + TKE_to_layer = TKE(i) * dRl * & + (3.0*dRbot*(Rint(K) - Rho_top(i)) + dRl**2) / dRbot**3 endif else ; TKE_to_layer = 0.0 ; endif ! TKE_Ray has been initialized to 0 above. - if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%Z_to_m * G%IareaT(i,j) * & + if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * G%IareaT(i,j) * & + US%m_to_Z**2 * US%T_to_s**3 * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1303,33 +1305,33 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & TKE(i) = TKE(i) - TKE_to_layer - if (Kd_lay(i,j,k) < (TKE_to_layer+TKE_Ray)*TKE_to_Kd(i,k)) then - delta_Kd = (TKE_to_layer+TKE_Ray)*TKE_to_Kd(i,k) - Kd_lay(i,j,k) + if (Kd_lay(i,j,k) < (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then + delta_Kd = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,j,k) if ((CS%Kd_max >= 0.0) .and. (delta_Kd > CS%Kd_max)) then delta_Kd = CS%Kd_max Kd_lay(i,j,k) = Kd_lay(i,j,k) + delta_Kd else - Kd_lay(i,j,k) = (TKE_to_layer+TKE_Ray)*TKE_to_Kd(i,k) + Kd_lay(i,j,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) endif - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*delta_Kd - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*delta_Kd + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * delta_Kd + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * delta_Kd if (do_diag_Kd_BBL) then - Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5*delta_Kd - Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5*delta_Kd + Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5 * delta_Kd + Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5 * delta_Kd endif endif else - if (Kd_lay(i,j,k) >= maxTKE(i,k)*TKE_to_Kd(i,k)) then + if (Kd_lay(i,j,k) >= maxTKE(i,k) * TKE_to_Kd(i,k)) then TKE_here = 0.0 TKE(i) = TKE(i) + TKE_Ray - elseif (Kd_lay(i,j,k) + (TKE_to_layer+TKE_Ray)*TKE_to_Kd(i,k) > & - maxTKE(i,k)*TKE_to_Kd(i,k)) then - TKE_here = ( (TKE_to_layer+TKE_Ray) + Kd_lay(i,j,k)/TKE_to_Kd(i,k) ) - & - maxTKE(i,k) + elseif (Kd_lay(i,j,k) + (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & + maxTKE(i,k) * TKE_to_Kd(i,k)) then + TKE_here = ((TKE_to_layer + TKE_Ray) + Kd_lay(i,j,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) + ! ### Non-bracketed ternary sum TKE(i) = TKE(i) - TKE_here + TKE_Ray else - TKE_here = TKE_to_layer + TKE_ray - TKE(i) = TKE(i) - TKE_to_Layer + TKE_here = TKE_to_layer + TKE_Ray + TKE(i) = TKE(i) - TKE_to_layer endif if (TKE(i) < 0.0) TKE(i) = 0.0 ! This should be unnecessary? @@ -1337,11 +1339,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & delta_Kd = TKE_here * TKE_to_Kd(i,k) if (CS%Kd_max >= 0.0) delta_Kd = min(delta_Kd, CS%Kd_max) Kd_lay(i,j,k) = Kd_lay(i,j,k) + delta_Kd - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*delta_Kd - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*delta_Kd + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * delta_Kd + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * delta_Kd if (do_diag_Kd_BBL) then - Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5*delta_Kd - Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5*delta_Kd + Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5 * delta_Kd + Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5 * delta_Kd endif endif endif @@ -1382,35 +1384,33 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & !! boundary layer properies, and related fields. integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G),SZK_(G)+1), & - intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [s-2] + intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 s-1 ~> m2 s-1] + intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - intent(inout) :: Kd_int !< Interface net diffusivity [Z2 s-1 ~> m2 s-1] - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 s-1 ~> m2 s-1] + intent(inout) :: Kd_int !< Interface net diffusivity [Z2 T-1 ~> m2 s-1] + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1] ! Local variables - real :: TKE_column ! net TKE input into the column [m3 s-3] - real :: TKE_to_layer ! TKE used to drive mixing in a layer [m3 s-3] - real :: TKE_Ray ! TKE from a layer Rayleigh drag used to drive mixing in that layer [m3 s-3] - real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [m3 s-3] - real :: TKE_consumed ! TKE used for mixing in this layer [m3 s-3] - real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [m3 s-3] + real :: TKE_column ! net TKE input into the column [Z3 T-3 ~> m3 s-3] + real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [Z3 T-3 ~> m3 s-3] + real :: TKE_consumed ! TKE used for mixing in this layer [Z3 T-3 ~> m3 s-3] + real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [Z3 T-3 ~> m3 s-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar ! value of ustar at a thickness point [Z s-1 ~> m s-1]. - real :: ustar2 ! square of ustar, for convenience [Z2 s-2 ~> m2 s-2] - real :: absf ! average absolute value of Coriolis parameter around a thickness point [s-1] + real :: ustar ! value of ustar at a thickness point [Z T-1 ~> m s-1]. + real :: ustar2 ! square of ustar, for convenience [Z2 T-2 ~> m2 s-2] + real :: absf ! average absolute value of Coriolis parameter around a thickness point [T-1 ~> s-1] real :: dh, dhm1 ! thickness of layers k and k-1, respecitvely [Z ~> m]. real :: z_bot ! distance to interface k from bottom [Z ~> m]. real :: D_minus_z ! distance to interface k from surface [Z ~> m]. real :: total_thickness ! total thickness of water column [Z ~> m]. real :: Idecay ! inverse of decay scale used for "Joule heating" loss of TKE with height [Z-1 ~> m-1]. - real :: Kd_wall ! Law of the wall diffusivity [Z2 s-1 ~> m2 s-1]. - real :: Kd_lower ! diffusivity for lower interface [Z2 s-1 ~> m2 s-1] - real :: ustar_D ! u* x D [Z2 s-1 ~> m2 s-1]. + real :: Kd_wall ! Law of the wall diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_lower ! diffusivity for lower interface [Z2 T-1 ~> m2 s-1] + real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. real :: I_Rho0 ! 1 / rho0 - real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [s-2] + real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] logical :: Rayleigh_drag ! Set to true if there are Rayleigh drag velocities defined in visc, on ! the assumption that this extracted energy also drives diapycnal mixing. integer :: i, k, km1 @@ -1421,7 +1421,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & do_diag_Kd_BBL = associated(Kd_BBL) N2_min = 0. - if (CS%LOTW_BBL_use_omega) N2_min = (CS%omega**2) + if (CS%LOTW_BBL_use_omega) N2_min = CS%omega**2 ! Determine whether to add Rayleigh drag contribution to TKE Rayleigh_drag = .false. @@ -1429,32 +1429,32 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & I_Rho0 = 1.0/GV%Rho0 cdrag_sqrt = sqrt(CS%cdrag) - TKE_Ray = 0. ! In case Rayleigh_drag is not used. do i=G%isc,G%iec ! Developed in single-column mode ! Column-wise parameters. - absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! + absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! ! u* at the bottom [m s-1]. - ustar = visc%ustar_BBL(i,j) + ustar = US%T_to_s * visc%ustar_BBL(i,j) ustar2 = ustar**2 ! In add_drag_diffusivity(), fluxes%ustar_tidal is added in. This might be double counting ! since ustar_BBL should already include all contributions to u*? -AJA - if (associated(fluxes%ustar_tidal)) ustar = ustar + US%m_to_Z*fluxes%ustar_tidal(i,j) + if (associated(fluxes%ustar_tidal)) ustar = ustar + (US%m_to_Z * US%T_to_s * fluxes%ustar_tidal(i,j)) ! The maximum decay scale should be something of order 200 m. We use the smaller of u*/f and ! (IMax_decay)^-1 as the decay scale. If ustar = 0, this is land so this value doesn't matter. Idecay = CS%IMax_decay - if ((ustar > 0.0) .and. (absf > CS%IMax_decay*ustar)) Idecay = absf / ustar + if ((ustar > 0.0) .and. (absf > CS%IMax_decay * ustar)) Idecay = absf / ustar - ! Energy input at the bottom [m3 s-3]. - ! (Note that visc%TKE_BBL is in m3 s-3, set in set_BBL_TKE().) + ! Energy input at the bottom [Z3 T-3 ~> m3 s-3]. + ! (Note that visc%TKE_BBL is in [Z3 T-3 ~> m3 s-3], set in set_BBL_TKE().) ! I am still unsure about sqrt(cdrag) in this expressions - AJA TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) ! Add in tidal dissipation energy at the bottom [m3 s-3]. ! Note that TKE_tidal is in [W m-2]. - if (associated(fluxes%TKE_tidal)) TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * I_Rho0 + if (associated(fluxes%TKE_tidal)) & + TKE_column = TKE_column + US%m_to_Z**3*US%T_to_s**3 * fluxes%TKE_tidal(i,j) * I_Rho0 TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column @@ -1472,7 +1472,8 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! Add in additional energy input from bottom-drag against slopes (sides) if (Rayleigh_drag) TKE_remaining = TKE_remaining + & - 0.5*CS%BBL_effic * US%Z_to_m * G%IareaT(i,j) * & + US%m_to_Z**2 * US%T_to_s**3 * & + 0.5*CS%BBL_effic * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1490,18 +1491,18 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & if ( ustar_D + absf * ( z_bot * D_minus_z ) == 0.) then Kd_wall = 0. else - Kd_wall = ( ( von_karm * ustar2 ) * ( z_bot * D_minus_z ) ) / & - ( ustar_D + absf * ( z_bot * D_minus_z ) ) + Kd_wall = ((von_karm * ustar2) * (z_bot * D_minus_z)) & + / (ustar_D + absf * (z_bot * D_minus_z)) endif ! TKE associated with Kd_wall [m3 s-2]. ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = US%Z_to_m**3*Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. if (TKE_Kd_wall > 0.) then TKE_consumed = min(TKE_Kd_wall, TKE_remaining) - Kd_wall = (TKE_consumed/TKE_Kd_wall) * Kd_wall ! Scale Kd so that only TKE_consumed is used. + Kd_wall = (TKE_consumed / TKE_Kd_wall) * Kd_wall ! Scale Kd so that only TKE_consumed is used. else ! Either N2=0 or dh = 0. if (TKE_remaining > 0.) then @@ -1517,7 +1518,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! Add this BBL diffusivity to the model net diffusivity. Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_wall - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*(Kd_wall + Kd_lower) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * (Kd_wall + Kd_lower) Kd_lower = Kd_wall ! Store for next level up. if (do_diag_Kd_BBL) Kd_BBL(i,j,K) = Kd_wall enddo ! k @@ -1535,30 +1536,30 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, type(forcing), intent(in) :: fluxes !< Surface fluxes structure type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 s-1 ~> m2 s-1]. + intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. ! This routine adds effects of mixed layer radiation to the layer diffusivities. real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. - real, dimension(SZI_(G)) :: TKE_ml_flux + real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [Z3 T-3 ~> m3 s-3] real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. - real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation [Z2 s-1 ~> m2 s-1]. + real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation [Z2 T-1 ~> m2 s-1]. - real :: f_sq ! The square of the local Coriolis parameter or a related variable [s-2]. + real :: f_sq ! The square of the local Coriolis parameter or a related variable [T-2 ~> s-2]. real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2]. - real :: ustar_sq ! ustar squared [Z2 s-2 ~> m2 s-2] - real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation [Z2 s-1 ~> m2 s-1]. + real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] + real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation [Z2 T-1 ~> m2 s-1]. real :: C1_6 ! 1/6 - real :: Omega2 ! rotation rate squared [s-2]. + real :: Omega2 ! rotation rate squared [T-2 ~> s-2]. real :: z1 ! layer thickness times I_decay [nondim] real :: dzL ! thickness converted to heights [Z ~> m]. real :: I_decay_len2_TKE ! squared inverse decay lengthscale for @@ -1569,7 +1570,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, integer :: i, k, is, ie, nz, kml is = G%isc ; ie = G%iec ; nz = G%ke - Omega2 = CS%Omega**2 + Omega2 = CS%omega**2 C1_6 = 1.0 / 6.0 kml = GV%nkml h_neglect = GV%H_subroundoff*GV%H_to_Z @@ -1581,17 +1582,17 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, do i=is,ie ; if (do_i(i)) then if (CS%ML_omega_frac >= 1.0) then - f_sq = 4.0*Omega2 + f_sq = 4.0 * Omega2 else - f_sq = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + f_sq = 0.25 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) if (CS%ML_omega_frac > 0.0) & - f_sq = CS%ML_omega_frac*4.0*Omega2 + (1.0-CS%ML_omega_frac)*f_sq + f_sq = CS%ML_omega_frac * 4.0 * Omega2 + (1.0 - CS%ML_omega_frac) * f_sq endif - ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 + ustar_sq = max(US%T_to_s * fluxes%ustar(i,j), CS%ustar_min)**2 - TKE_ml_flux(i) = (CS%mstar*CS%ML_rad_coeff)*(US%Z_to_m**3*ustar_sq*fluxes%ustar(i,j)) + TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * (US%T_to_s * fluxes%ustar(i,j))) I_decay_len2_TKE = CS%TKE_decay**2 * (f_sq / ustar_sq) if (CS%ML_rad_TKE_decay) & @@ -1605,11 +1606,9 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, ! a more accurate Taylor series approximations for very thin layers. z1 = (GV%H_to_Z*h(i,j,kml+1)) * I_decay(i) if (z1 > 1e-5) then - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,kml+1)) * & - (1.0 - exp(-z1)) + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) else - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,kml+1)) * & - (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) endif Kd_mlr_ml(i) = min(Kd_mlr, CS%ML_rad_kd_max) TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) @@ -1623,7 +1622,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_mlr_ml(i) endif ; enddo ; enddo if (kml<=nz-1) then ; do i=is,ie ; if (do_i(i)) then - Kd_int(i,j,Kml+2) = Kd_int(i,j,Kml+2) + 0.5*Kd_mlr_ml(i) + Kd_int(i,j,Kml+2) = Kd_int(i,j,Kml+2) + 0.5 * Kd_mlr_ml(i) endif ; enddo ; endif endif @@ -1632,21 +1631,23 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, do i=is,ie ; if (do_i(i)) then dzL = GV%H_to_Z*h(i,j,k) ; z1 = dzL*I_decay(i) if (z1 > 1e-5) then - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & - US%m_to_Z * ((1.0 - exp(-z1)) / dzL) + !### I think that this might be dimensionally inconsistent, but untested. -RWH + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 ? + US%m_to_Z * ((1.0 - exp(-z1)) / dzL) ! Units of m-1 ? else - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & - US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) + !### I think that this might be dimensionally inconsistent, but untested. -RWH + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 ? + US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 ? endif Kd_mlr = min(Kd_mlr, CS%ML_rad_kd_max) Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_mlr if (present(Kd_int)) then - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*Kd_mlr - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*Kd_mlr + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * Kd_mlr + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * Kd_mlr endif TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) - if (TKE_ml_flux(i) * I_decay(i) < 0.1*CS%Kd_min*US%Z_to_m**3*Omega2) then + if (TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then do_i(i) = .false. else ; do_any = .true. ; endif endif ; enddo @@ -1783,7 +1784,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) G%areaCu(I,j)*(ustar(I)*ustar(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1)) + & G%areaCv(i,J)*(vstar(i,J)*vstar(i,J))) ) ) - visc%TKE_BBL(i,j) = US%Z_to_m * & + visc%TKE_BBL(i,j) = US%T_to_s**3 * US%m_to_Z**2 * & (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + & G%areaCu(I,j) * (ustar(I)*u2_bbl(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1)) + & @@ -1951,60 +1952,60 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z CS%Kdml = 0.0 ; CS%cdrag = 0.003 ; CS%BBL_effic = 0.0 CS%bulkmixedlayer = (GV%nkml > 0) - ! 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, default=".") CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "FLUX_RI_MAX", CS%FluxRi_max, & - "The flux Richardson number where the stratification is \n"//& - "large enough that N2 > omega2. The full expression for \n"//& - "the Flux Richardson number is usually \n"//& + "The flux Richardson number where the stratification is "//& + "large enough that N2 > omega2. The full expression for "//& + "the Flux Richardson number is usually "//& "FLUX_RI_MAX*N2/(N2+OMEGA2).", default=0.2) call get_param(param_file, mdl, "OMEGA", CS%omega, & "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5) + default=7.2921e-5, scale=US%T_to_s) call get_param(param_file, mdl, "ML_RADIATION", CS%ML_radiation, & - "If true, allow a fraction of TKE available from wind \n"//& - "work to penetrate below the base of the mixed layer \n"//& - "with a vertical decay scale determined by the minimum \n"//& - "of: (1) The depth of the mixed layer, (2) an Ekman \n"//& + "If true, allow a fraction of TKE available from wind "//& + "work to penetrate below the base of the mixed layer "//& + "with a vertical decay scale determined by the minimum "//& + "of: (1) The depth of the mixed layer, (2) an Ekman "//& "length scale.", default=.false.) if (CS%ML_radiation) then ! This give a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_subroundoff*GV%H_to_Z) + CS%ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + GV%H_subroundoff*GV%H_to_Z) call get_param(param_file, mdl, "ML_RAD_EFOLD_COEFF", CS%ML_rad_efold_coeff, & - "A coefficient that is used to scale the penetration \n"//& - "depth for turbulence below the base of the mixed layer. \n"//& + "A coefficient that is used to scale the penetration "//& + "depth for turbulence below the base of the mixed layer. "//& "This is only used if ML_RADIATION is true.", units="nondim", & default=0.2) call get_param(param_file, mdl, "ML_RAD_KD_MAX", CS%ML_rad_kd_max, & - "The maximum diapycnal diffusivity due to turbulence \n"//& - "radiated from the base of the mixed layer. \n"//& + "The maximum diapycnal diffusivity due to turbulence "//& + "radiated from the base of the mixed layer. "//& "This is only used if ML_RADIATION is true.", & - units="m2 s-1", default=1.0e-3, scale=US%m_to_Z**2) + units="m2 s-1", default=1.0e-3, & + scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ML_RAD_COEFF", CS%ML_rad_coeff, & - "The coefficient which scales MSTAR*USTAR^3 to obtain \n"//& - "the energy available for mixing below the base of the \n"//& + "The coefficient which scales MSTAR*USTAR^3 to obtain "//& + "the energy available for mixing below the base of the "//& "mixed layer. This is only used if ML_RADIATION is true.", & units="nondim", default=0.2) call get_param(param_file, mdl, "ML_RAD_APPLY_TKE_DECAY", CS%ML_rad_TKE_decay, & - "If true, apply the same exponential decay to ML_rad as \n"//& - "is applied to the other surface sources of TKE in the \n"//& + "If true, apply the same exponential decay to ML_rad as "//& + "is applied to the other surface sources of TKE in the "//& "mixed layer code. This is only used if ML_RADIATION is true.", & default=.true.) call get_param(param_file, mdl, "MSTAR", CS%mstar, & - "The ratio of the friction velocity cubed to the TKE \n"//& + "The ratio of the friction velocity cubed to the TKE "//& "input to the mixed layer.", "units=nondim", default=1.2) call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & "The ratio of the natural Ekman depth to the TKE decay scale.", & units="nondim", default=2.5) call get_param(param_file, mdl, "ML_USE_OMEGA", ML_use_omega, & - "If true, use the absolute rotation rate instead of the \n"//& - "vertical component of rotation when setting the decay \n"//& + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (ML_use_omega) then @@ -2012,59 +2013,60 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%ML_omega_frac, & - "When setting the decay scale for turbulence, use this \n"//& - "fraction of the absolute rotation rate blended with the \n"//& + "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).", & units="nondim", default=omega_frac_dflt) endif call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & - "If true, the bottom stress is calculated with a drag \n"//& - "law of the form c_drag*|u|*u. The velocity magnitude \n"//& - "may be an assumed value or it may be based on the \n"//& - "actual velocity in the bottommost HBBL, depending on \n"//& + "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.", default=.true.) if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & - "The drag coefficient relating the magnitude of the \n"//& - "velocity field to the bottom stress. CDRAG is only used \n"//& + "The drag coefficient relating the magnitude of the "//& + "velocity field to the bottom stress. CDRAG is only used "//& "if BOTTOMDRAGLAW is true.", units="nondim", default=0.003) call get_param(param_file, mdl, "BBL_EFFIC", CS%BBL_effic, & - "The efficiency with which the energy extracted by \n"//& - "bottom drag drives BBL diffusion. This is only \n"//& + "The efficiency with which the energy extracted by "//& + "bottom drag drives BBL diffusion. This is only "//& "used if BOTTOMDRAGLAW is true.", units="nondim", default=0.20) call get_param(param_file, mdl, "BBL_MIXING_MAX_DECAY", decay_length, & - "The maximum decay scale for the BBL diffusion, or 0 \n"//& - "to allow the mixing to penetrate as far as \n"//& - "stratification and rotation permit. The default is 0. \n"//& + "The maximum decay scale for the BBL diffusion, or 0 "//& + "to allow the mixing to penetrate as far as "//& + "stratification and rotation permit. The default is 0. "//& "This is only used if BOTTOMDRAGLAW is true.", & units="m", default=0.0, scale=US%m_to_Z) CS%IMax_decay = 1.0 / (200.0*US%m_to_Z) !### This is inconsistent with the description above. if (decay_length > 0.0) CS%IMax_decay = 1.0/decay_length call get_param(param_file, mdl, "BBL_MIXING_AS_MAX", CS%BBL_mixing_as_max, & - "If true, take the maximum of the diffusivity from the \n"//& - "BBL mixing and the other diffusivities. Otherwise, \n"//& - "diffusiviy from the BBL_mixing is simply added.", & + "If true, take the maximum of the diffusivity from the "//& + "BBL mixing and the other diffusivities. Otherwise, "//& + "diffusivity from the BBL_mixing is simply added.", & default=.true.) call get_param(param_file, mdl, "USE_LOTW_BBL_DIFFUSIVITY", CS%use_LOTW_BBL_diffusivity, & - "If true, uses a simple, imprecise but non-coordinate dependent, model\n"//& - "of BBL mixing diffusivity based on Law of the Wall. Otherwise, uses\n"//& + "If true, uses a simple, imprecise but non-coordinate dependent, model "//& + "of BBL mixing diffusivity based on Law of the Wall. Otherwise, uses "//& "the original BBL scheme.", default=.false.) if (CS%use_LOTW_BBL_diffusivity) then call get_param(param_file, mdl, "LOTW_BBL_USE_OMEGA", CS%LOTW_BBL_use_omega, & - "If true, use the maximum of Omega and N for the TKE to diffusion\n"//& + "If true, use the maximum of Omega and N for the TKE to diffusion "//& "calculation. Otherwise, N is N.", default=.true.) endif else CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL endif CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & - 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=US%Z_to_m**2) + 'Bottom Boundary Layer Diffusivity', 'm2 s-1', & + conversion=US%Z2_T_to_m2_s) call get_param(param_file, mdl, "SIMPLE_TKE_TO_KD", CS%simple_TKE_to_Kd, & - "If true, uses a simple estimate of Kd/TKE that will\n"//& - "work for arbitrary vertical coordinates. If false,\n"//& - "calculates Kd/TKE and bounds based on exact energetics/n"//& + "If true, uses a simple estimate of Kd/TKE that will "//& + "work for arbitrary vertical coordinates. If false, "//& + "calculates Kd/TKE and bounds based on exact energetics "//& "for an isopycnal layer-formulation.", & default=.false.) @@ -2072,27 +2074,31 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp) call get_param(param_file, mdl, "KV", CS%Kv, & - "The background kinematic viscosity in the interior. \n"//& + "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m_to_Z**2, fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, & + fail_if_missing=.true.) call get_param(param_file, mdl, "KD", CS%Kd, & - "The background diapycnal diffusivity of density in the \n"//& - "interior. Zero or the molecular value, ~1e-7 m2 s-1, \n"//& - "may be used.", units="m2 s-1", scale=US%m_to_Z**2, fail_if_missing=.true.) + "The background diapycnal diffusivity of density in the "//& + "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& + "may be used.", units="m2 s-1", scale=US%m2_s_to_Z2_T, & + fail_if_missing=.true.) call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z_to_m**2, scale=US%m_to_Z**2) + units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, & + scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & - "The maximum permitted increment for the diapycnal \n"//& - "diffusivity from TKE-based parameterizations, or a \n"//& - "negative value for no limit.", units="m2 s-1", default=-1.0, scale=US%m_to_Z**2) + "The maximum permitted increment for the diapycnal "//& + "diffusivity from TKE-based parameterizations, or a "//& + "negative value for no limit.", units="m2 s-1", default=-1.0, & + scale=US%m2_s_to_Z2_T) if (CS%simple_TKE_to_Kd .and. CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: To use SIMPLE_TKE_TO_KD, KD_MAX must be set to >0.") call get_param(param_file, mdl, "KD_ADD", CS%Kd_add, & - "A uniform diapycnal diffusivity that is added \n"//& + "A uniform diapycnal diffusivity that is added "//& "everywhere without any filtering or scaling.", & - units="m2 s-1", default=0.0, scale=US%m_to_Z**2) + units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) if (CS%use_LOTW_BBL_diffusivity .and. CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: KD_MAX must be set (positive) when "// & "USE_LOTW_BBL_DIFFUSIVITY=True.") @@ -2106,14 +2112,16 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z CS%Kdml = CS%Kd ! This is not used with a bulk mixed layer, but also ! cannot be a NaN. else + ! ### This parameter is unused and is staged for deletion call get_param(param_file, mdl, "KDML", CS%Kdml, & - "If BULKMIXEDLAYER is false, KDML is the elevated \n"//& - "diapycnal diffusivity in the topmost HMIX of fluid. \n"//& + "If BULKMIXEDLAYER is false, KDML is the elevated "//& + "diapycnal diffusivity in the topmost HMIX of fluid. "//& "KDML is only used if BULKMIXEDLAYER is false.", & - units="m2 s-1", default=CS%Kd*US%Z_to_m**2, scale=US%m_to_Z**2) + units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, & + scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & - "The prescribed depth over which the near-surface \n"//& - "viscosity and diffusivity are elevated when the bulk \n"//& + "The prescribed depth over which the near-surface "//& + "viscosity and diffusivity are elevated when the bulk "//& "mixed layer is not used.", units="m", fail_if_missing=.true.) endif call get_param(param_file, mdl, "DEBUG", CS%debug, & @@ -2125,21 +2133,23 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z default=.false.) call get_param(param_file, mdl, "DISSIPATION_MIN", CS%dissip_min, & - "The minimum dissipation by which to determine a lower \n"//& - "bound of Kd (a floor).", units="W m-3", default=0.0, scale=US%m_to_Z**2) + "The minimum dissipation by which to determine a lower "//& + "bound of Kd (a floor).", units="W m-3", default=0.0, & + scale=US%m2_s_to_Z2_T*(US%T_to_s**2)) call get_param(param_file, mdl, "DISSIPATION_N0", CS%dissip_N0, & - "The intercept when N=0 of the N-dependent expression \n"//& - "used to set a minimum dissipation by which to determine \n"//& + "The intercept when N=0 of the N-dependent expression "//& + "used to set a minimum dissipation by which to determine "//& "a lower bound of Kd (a floor): A in eps_min = A + B*N.", & - units="W m-3", default=0.0, scale=US%m_to_Z**2) + units="W m-3", default=0.0, & + scale=US%m2_s_to_Z2_T*(US%T_to_s**2)) call get_param(param_file, mdl, "DISSIPATION_N1", CS%dissip_N1, & - "The coefficient multiplying N, following Gargett, used to \n"//& - "set a minimum dissipation by which to determine a lower \n"//& + "The coefficient multiplying N, following Gargett, used to "//& + "set a minimum dissipation by which to determine a lower "//& "bound of Kd (a floor): B in eps_min = A + B*N", & - units="J m-3", default=0.0, scale=US%m_to_Z**2) + units="J m-3", default=0.0, scale=US%m2_s_to_Z2_T*US%T_to_s) call get_param(param_file, mdl, "DISSIPATION_KD_MIN", CS%dissip_Kd_min, & "The minimum vertical diffusivity applied as a floor.", & - units="m2 s-1", default=0.0, scale=US%m_to_Z**2) + units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) CS%limit_dissipation = (CS%dissip_min>0.) .or. (CS%dissip_N1>0.) .or. & (CS%dissip_N0>0.) .or. (CS%dissip_Kd_min>0.) @@ -2148,39 +2158,42 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z CS%dissip_N2 = CS%dissip_Kd_min * GV%Rho0 / CS%FluxRi_max CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & - 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=US%Z_to_m**2) + 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', & + conversion=US%Z2_T_to_m2_s) if (CS%tm_csp%Int_tide_dissipation .or. CS%tm_csp%Lee_wave_dissipation .or. & CS%tm_csp%Lowmode_itidal_dissipation) then CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & - 'Work done by Diapycnal Mixing', 'W m-2') + 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%Z_to_m**3*US%s_to_T**3) CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & - 'Maximum layer TKE', 'm3 s-3') + 'Maximum layer TKE', 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & - 'Convert TKE to Kd', 's2 m', conversion=US%Z_to_m**2) + 'Convert TKE to Kd', 's2 m', & + conversion=US%Z2_T_to_m2_s*(US%m_to_Z**3*US%T_to_s**3)) CS%id_N2 = register_diag_field('ocean_model', 'N2', diag%axesTi, Time, & 'Buoyancy frequency squared', 's-2', cmor_field_name='obvfsq', & cmor_long_name='Square of seawater buoyancy frequency', & - cmor_standard_name='square_of_brunt_vaisala_frequency_in_sea_water') + cmor_standard_name='square_of_brunt_vaisala_frequency_in_sea_water', & + conversion=US%s_to_T**2) if (CS%user_change_diff) & CS%id_Kd_user = register_diag_field('ocean_model', 'Kd_user', diag%axesTi, Time, & - 'User-specified Extra Diffusivity', 'm2 s-1', conversion=US%Z_to_m**2) + 'User-specified Extra Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) if (associated(diag_to_Z_CSp)) then vd = var_desc("N2", "s-2", & "Buoyancy frequency, interpolated to z", z_grid='z') - CS%id_N2_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) + CS%id_N2_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%s_to_T**2) if (CS%user_change_diff) & - CS%id_Kd_user_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) + CS%id_Kd_user_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z2_T_to_m2_s) endif endif call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, & - "If true, increase diffusivitives for temperature or salt \n"//& - "based on double-diffusive paramaterization from MOM4/KPP.", & + "If true, increase diffusivites for temperature or salt "//& + "based on double-diffusive parameterization from MOM4/KPP.", & default=.false.) if (CS%double_diffusion) then @@ -2189,30 +2202,36 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z default=2.55, units="nondim") call get_param(param_file, mdl, "MAX_SALT_DIFF_SALT_FINGERS", CS%Max_salt_diff_salt_fingers, & "Maximum salt diffusivity for salt fingering regime.", & - default=1.e-4, units="m2 s-1") + default=1.e-4, units="m2 s-1", scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & - "Molecular viscosity for calculation of fluxes under \n"//& - "double-diffusive convection.", default=1.5e-6, units="m2 s-1") + "Molecular viscosity for calculation of fluxes under "//& + "double-diffusive convection.", default=1.5e-6, units="m2 s-1", & + scale=US%m2_s_to_Z2_T) ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. CS%id_KT_extra = register_diag_field('ocean_model', 'KT_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=US%Z_to_m**2) + 'Double-diffusive diffusivity for temperature', 'm2 s-1', & + conversion=US%Z2_T_to_m2_s) CS%id_KS_extra = register_diag_field('ocean_model', 'KS_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=US%Z_to_m**2) + 'Double-diffusive diffusivity for salinity', 'm2 s-1', & + conversion=US%Z2_T_to_m2_s) if (associated(diag_to_Z_CSp)) then vd = var_desc("KT_extra", "m2 s-1", & "Double-Diffusive Temperature Diffusivity, interpolated to z", & z_grid='z') - CS%id_KT_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) + CS%id_KT_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, & + conversion=US%Z2_T_to_m2_s) vd = var_desc("KS_extra", "m2 s-1", & "Double-Diffusive Salinity Diffusivity, interpolated to z", & z_grid='z') - CS%id_KS_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) + CS%id_KS_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, & + conversion=US%Z2_T_to_m2_s) vd = var_desc("Kd_BBL", "m2 s-1", & "Bottom Boundary Layer Diffusivity", z_grid='z') - CS%id_Kd_BBL_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) + CS%id_Kd_BBL_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, & + conversion=US%Z2_T_to_m2_s) endif endif ! old double-diffusion diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 7eba2fbac0..1265067ef2 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -19,6 +19,7 @@ module MOM_set_visc use MOM_cvmix_conv, only : cvmix_conv_is_used use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : register_restart_field_as_obsolete use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type @@ -625,8 +626,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! The bottom boundary layer thickness is found by solving the same ! equation as in Killworth and Edwards: (h/h_f)^2 + h/h_N = 1. - if (m==1) then ; C2f = (G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) - else ; C2f = (G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)) ; endif + if (m==1) then ; C2f = US%s_to_T*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) + else ; C2f = US%s_to_T*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)) ; endif if (CS%cdrag * U_bg_sq <= 0.0) then ! This avoids NaNs and overflows, and could be used in all cases, @@ -1202,7 +1203,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri (forces%tauy(i,J-1) + forces%tauy(i+1,J))) if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else - absf = 0.5*(abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I,J-1))) + absf = 0.5*US%s_to_T*(abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I,J-1))) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif @@ -1405,10 +1406,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri !visc%tbl_thick_shelf_u(I,j) = GV%H_to_Z * max(CS%Htbl_shelf_min, & ! htot(I) / (0.5 + sqrt(0.25 + & - ! (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2 / & + ! (htot(i)*US%s_to_T*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2 / & ! (ustar(i)*GV%Z_to_H)**2 )) ) ustar1 = ustar(i)*GV%Z_to_H - h2f2 = (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) + h_neglect*CS%Omega)**2 + h2f2 = (htot(i)*US%s_to_T*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) + h_neglect*CS%Omega)**2 tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & ( htot(I)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) visc%tbl_thick_shelf_u(I,j) = tbl_thick_Z @@ -1437,7 +1438,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri (forces%taux(I-1,j) + forces%taux(I,j+1))) if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else - absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + absf = 0.5*US%s_to_T*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif @@ -1642,10 +1643,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri !visc%tbl_thick_shelf_v(i,J) = GV%H_to_Z * max(CS%Htbl_shelf_min, & ! htot(i) / (0.5 + sqrt(0.25 + & - ! (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))**2 / & + ! (htot(i)*US%s_to_T*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))**2 / & ! (ustar(i)*GV%Z_to_H)**2 )) ) ustar1 = ustar(i)*GV%Z_to_H - h2f2 = (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)) + h_neglect*CS%Omega)**2 + h2f2 = (htot(i)*US%s_to_T*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)) + h_neglect*CS%Omega)**2 tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & ( htot(i)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) visc%tbl_thick_shelf_v(i,J) = tbl_thick_Z @@ -1699,12 +1700,12 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) use_CVMix_shear = CVMix_shear_is_used(param_file) use_CVMix_conv = CVMix_conv_is_used(param_file) call get_param(param_file, mdl, "USE_KPP", useKPP, & - "If true, turns on the [CVMix] KPP scheme of Large et al., 1984,\n"// & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& "to calculate diffusivities and non-local transport in the OBL.", & default=.false., do_not_log=.true.) call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", useEPBL, & - "If true, use an implied energetics planetary boundary \n"//& - "layer scheme to determine the diffusivity and viscosity \n"//& + "If true, use an implied energetics planetary boundary "//& + "layer scheme to determine the diffusivity and viscosity "//& "in the surface boundary layer.", default=.false., do_not_log=.true.) endif @@ -1811,65 +1812,65 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%RiNo_mix = .false. ; use_CVMix_ddiff = .false. differential_diffusion = .false. call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & - "If true, the bottom stress is calculated with a drag \n"//& - "law of the form c_drag*|u|*u. The velocity magnitude \n"//& - "may be an assumed value or it may be based on the \n"//& - "actual velocity in the bottommost HBBL, depending on \n"//& + "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.", default=.true.) call get_param(param_file, mdl, "CHANNEL_DRAG", CS%Channel_drag, & - "If true, the bottom drag is exerted directly on each \n"//& - "layer proportional to the fraction of the bottom it \n"//& + "If true, the bottom drag is exerted directly on each "//& + "layer proportional to the fraction of the bottom it "//& "overlies.", default=.false.) call get_param(param_file, mdl, "LINEAR_DRAG", CS%linear_drag, & - "If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag \n"//& + "If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag "//& "law is cdrag*DRAG_BG_VEL*u.", default=.false.) call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & do_not_log=.true.) if (adiabatic) then call log_param(param_file, mdl, "ADIABATIC",adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is \n"//& - "true. This assumes that KD = KDML = 0.0 and that \n"//& - "there is no buoyancy forcing, but makes the model \n"//& + "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.) endif if (.not.adiabatic) then CS%RiNo_mix = kappa_shear_is_used(param_file) call get_param(param_file, mdl, "DOUBLE_DIFFUSION", differential_diffusion, & - "If true, increase diffusivitives for temperature or salt \n"//& - "based on double-diffusive paramaterization from MOM4/KPP.", & + "If true, increase diffusivites for temperature or salt "//& + "based on double-diffusive parameterization from MOM4/KPP.", & default=.false.) use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) endif call get_param(param_file, mdl, "PRANDTL_TURB", visc%Prandtl_turb, & - "The turbulent Prandtl number applied to shear \n"//& + "The turbulent Prandtl number applied to shear "//& "instability.", units="nondim", default=1.0) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "DYNAMIC_VISCOUS_ML", CS%dynamic_viscous_ML, & - "If true, use a bulk Richardson number criterion to \n"//& + "If true, use a bulk Richardson number criterion to "//& "determine the mixed layer thickness for viscosity.", & default=.false.) if (CS%dynamic_viscous_ML) then call get_param(param_file, mdl, "BULK_RI_ML", bulk_Ri_ML_dflt, default=0.0) call get_param(param_file, mdl, "BULK_RI_ML_VISC", CS%bulk_Ri_ML, & - "The efficiency with which mean kinetic energy released \n"//& - "by mechanically forced entrainment of the mixed layer \n"//& - "is converted to turbulent kinetic energy. By default, \n"//& + "The efficiency with which mean kinetic energy released "//& + "by mechanically forced entrainment of the mixed layer "//& + "is converted to turbulent kinetic energy. By default, "//& "BULK_RI_ML_VISC = BULK_RI_ML or 0.", units="nondim", & default=bulk_Ri_ML_dflt) call get_param(param_file, mdl, "TKE_DECAY", TKE_decay_dflt, default=0.0) call get_param(param_file, mdl, "TKE_DECAY_VISC", CS%TKE_decay, & - "TKE_DECAY_VISC relates the vertical rate of decay of \n"//& - "the TKE available for mechanical entrainment to the \n"//& - "natural Ekman depth for use in calculating the dynamic \n"//& - "mixed layer viscosity. By default, \n"//& + "TKE_DECAY_VISC relates the vertical rate of decay of "//& + "the TKE available for mechanical entrainment to the "//& + "natural Ekman depth for use in calculating the dynamic "//& + "mixed layer viscosity. By default, "//& "TKE_DECAY_VISC = TKE_DECAY or 0.", units="nondim", & default=TKE_decay_dflt) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & - "If true, use the absolute rotation rate instead of the \n"//& - "vertical component of rotation when setting the decay \n"//& + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then @@ -1877,8 +1878,8 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & - "When setting the decay scale for turbulence, use this \n"//& - "fraction of the absolute rotation rate blended with the \n"//& + "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).", & units="nondim", default=omega_frac_dflt) call get_param(param_file, mdl, "OMEGA", CS%omega, & @@ -1893,62 +1894,62 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS endif call get_param(param_file, mdl, "HBBL", CS%Hbbl, & - "The thickness of a bottom boundary layer with a \n"//& - "viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or \n"//& - "the thickness over which near-bottom velocities are \n"//& - "averaged for the drag law if BOTTOMDRAGLAW is defined \n"//& + "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.", units="m", fail_if_missing=.true.) ! Rescaled later if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & - "CDRAG is the drag coefficient relating the magnitude of \n"//& - "the velocity field to the bottom stress. CDRAG is only \n"//& + "CDRAG is the drag coefficient relating the magnitude of "//& + "the velocity field to the bottom stress. CDRAG is only "//& "used if BOTTOMDRAGLAW is defined.", units="nondim", & default=0.003) call get_param(param_file, mdl, "DRAG_BG_VEL", CS%drag_bg_vel, & - "DRAG_BG_VEL is either the assumed bottom velocity (with \n"//& - "LINEAR_DRAG) or an unresolved velocity that is \n"//& - "combined with the resolved velocity to estimate the \n"//& - "velocity magnitude. DRAG_BG_VEL is only used when \n"//& + "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.", units="m s-1", default=0.0) call get_param(param_file, mdl, "BBL_USE_EOS", CS%BBL_use_EOS, & - "If true, use the equation of state in determining the \n"//& - "properties of the bottom boundary layer. Otherwise use \n"//& + "If true, use the equation of state in determining the "//& + "properties of the bottom boundary layer. Otherwise use "//& "the layer target potential densities.", default=.false.) endif call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & - "The minimum bottom boundary layer thickness that can be \n"//& - "used with BOTTOMDRAGLAW. This might be \n"//& - "Kv / (cdrag * drag_bg_vel) to give Kv as the minimum \n"//& + "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.", units="m", default=0.0) ! Rescaled later call get_param(param_file, mdl, "HTBL_SHELF_MIN", CS%Htbl_shelf_min, & - "The minimum top boundary layer thickness that can be \n"//& - "used with BOTTOMDRAGLAW. This might be \n"//& - "Kv / (cdrag * drag_bg_vel) to give Kv as the minimum \n"//& + "The minimum top boundary layer thickness that can be "//& + "used with BOTTOMDRAGLAW. This might be "//& + "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& "near-top viscosity.", units="m", default=CS%BBL_thick_min, scale=GV%m_to_H) call get_param(param_file, mdl, "HTBL_SHELF", CS%Htbl_shelf, & - "The thickness over which near-surface velocities are \n"//& - "averaged for the drag law under an ice shelf. By \n"//& + "The thickness over which near-surface velocities are "//& + "averaged for the drag law under an ice shelf. By "//& "default this is the same as HBBL", units="m", default=CS%Hbbl, scale=GV%m_to_H) ! These unit conversions are out outside the get_param calls because the are also defaults. CS%Hbbl = CS%Hbbl * GV%m_to_H ! Rescale CS%BBL_thick_min = CS%BBL_thick_min * GV%m_to_H ! Rescale call get_param(param_file, mdl, "KV", Kv_background, & - "The background kinematic viscosity in the interior. \n"//& + "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true.) call get_param(param_file, mdl, "ADD_KV_SLOW", visc%add_Kv_slow, & - "If true, the background vertical viscosity in the interior \n"//& - "(i.e., tidal + background + shear + convenction) is addded \n"// & - "when computing the coupling coefficient. The purpose of this \n"// & - "flag is to be able to recover previous answers and it will likely \n"// & + "If true, the background vertical viscosity in the interior "//& + "(i.e., tidal + background + shear + convection) is added "//& + "when computing the coupling coefficient. The purpose of this "//& + "flag is to be able to recover previous answers and it will likely "//& "be removed in the future since this option should always be true.", & default=.false.) call get_param(param_file, mdl, "USE_KPP", use_KPP, & - "If true, turns on the [CVMix] KPP scheme of Large et al., 1994,\n"// & - "to calculate diffusivities and non-local transport in the OBL.", & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& + "to calculate diffusivities and non-local transport in the OBL.", & do_not_log=.true., default=.false.) if (use_KPP .and. visc%add_Kv_slow) call MOM_error(FATAL,"set_visc_init: "//& @@ -1970,10 +1971,10 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (smag_const1 >= 0.0) cSmag_chan_dflt = smag_const1 call get_param(param_file, mdl, "SMAG_CONST_CHANNEL", CS%c_Smag, & - "The nondimensional Laplacian Smagorinsky constant used \n"//& - "in calculating the channel drag if it is enabled. The \n"//& - "default is to use the same value as SMAG_LAP_CONST if \n"//& - "it is defined, or 0.15 if it is not. The value used is \n"//& + "The nondimensional Laplacian Smagorinsky constant used "//& + "in calculating the channel drag if it is enabled. The "//& + "default is to use the same value as SMAG_LAP_CONST if "//& + "it is defined, or 0.15 if it is not. The value used is "//& "also 0.15 if the specified value is negative.", & units="nondim", default=cSmag_chan_dflt) if (CS%c_Smag < 0.0) CS%c_Smag = 0.15 @@ -2025,6 +2026,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'm') endif + call register_restart_field_as_obsolete('Kd_turb','Kd_shear', restart_CS) + call register_restart_field_as_obsolete('Kv_turb','Kv_shear', restart_CS) + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then Z_rescale = US%m_to_Z / US%m_to_Z_restart if (associated(visc%Kd_shear)) then ; if (query_initialized(visc%Kd_shear, "Kd_shear", restart_CS)) then diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index eaa2faf765..978e8d1807 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -118,8 +118,8 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & ! Set default, read and log parameters call log_version(param_file, mdl, version) call get_param(param_file, mdl, "SPONGE", use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) if (.not.use_sponge) return @@ -188,7 +188,7 @@ end subroutine initialize_sponge !> This subroutine sets up diagnostics for the sponges. It is separate !! from initialize_sponge because it requires fields that are not readily -!! availble where initialize_sponge is called. +!! available where initialize_sponge is called. subroutine init_sponge_diags(Time, G, diag, CS) type(time_type), target, intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 6f85bc5dbe..39bec8cccb 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -45,11 +45,11 @@ module MOM_tidal_mixing type, public :: tidal_mixing_diags ; private real, pointer, dimension(:,:,:) :: & Kd_itidal => NULL(),& !< internal tide diffusivity at interfaces [Z2 s-1 ~> m2 s-1]. - Fl_itidal => NULL(),& !< vertical flux of tidal turbulent dissipation [m3 s-3] + Fl_itidal => NULL(),& !< vertical flux of tidal turbulent dissipation [Z3 T-3 ~> m3 s-3] Kd_Niku => NULL(),& !< lee-wave diffusivity at interfaces [Z2 s-1 ~> m2 s-1]. - Kd_Niku_work => NULL(),& !< layer integrated work by lee-wave driven mixing [W m-2] - Kd_Itidal_Work => NULL(),& !< layer integrated work by int tide driven mixing [W m-2] - Kd_Lowmode_Work => NULL(),& !< layer integrated work by low mode driven mixing [W m-2] + Kd_Niku_work => NULL(),& !< layer integrated work by lee-wave driven mixing [kg Z3 m-3 T-3 ~> W m-2] + Kd_Itidal_Work => NULL(),& !< layer integrated work by int tide driven mixing [kg Z3 m-3 T-3 ~> W m-2] + Kd_Lowmode_Work => NULL(),& !< layer integrated work by low mode driven mixing [kg Z3 m-3 T-3 ~> W m-2] N2_int => NULL(),& !< Bouyancy frequency squared at interfaces [s-2] vert_dep_3d => NULL(),& !< The 3-d mixing energy deposition [W m-3] Schmittner_coeff_3d => NULL() !< The coefficient in the Schmittner et al mixing scheme, in UNITS? @@ -58,9 +58,9 @@ module MOM_tidal_mixing real, pointer, dimension(:,:,:) :: Kd_lowmode => NULL() !< internal tide diffusivity at interfaces !! due to propagating low modes [Z2 s-1 ~> m2 s-1]. real, pointer, dimension(:,:,:) :: Fl_lowmode => NULL() !< vertical flux of tidal turbulent - !! dissipation due to propagating low modes [m3 s-3] + !! dissipation due to propagating low modes [Z3 T-3 ~> m3 s-3] real, pointer, dimension(:,:) :: & - TKE_itidal_used => NULL(),& !< internal tide TKE input at ocean bottom [W m-2] + TKE_itidal_used => NULL(),& !< internal tide TKE input at ocean bottom [kg Z3 m-3 T-3 ~> W m-2] N2_bot => NULL(),& !< bottom squared buoyancy frequency [s-2] N2_meanz => NULL(),& !< vertically averaged buoyancy frequency [s-2] Polzin_decay_scale_scaled => NULL(),& !< vertical scale of decay for tidal dissipation @@ -123,10 +123,10 @@ module MOM_tidal_mixing real :: Polzin_min_decay_scale !< minimum decay scale of the tidal dissipation !! profile in Polzin formulation [Z ~> m]. - real :: TKE_itide_max !< maximum internal tide conversion [W m-2] + real :: TKE_itide_max !< maximum internal tide conversion [kg Z3 m-3 T-3 ~> W m-2] !! available to mix above the BBL - real :: utide !< constant tidal amplitude [m s-1] used if + real :: utide !< constant tidal amplitude [Z T-1 ~> m s-1] if READ_TIDEAMP is false. real :: kappa_itides !< topographic wavenumber and non-dimensional scaling [Z-1 ~> m-1]. real :: kappa_h2_factor !< factor for the product of wavenumber * rms sgs height character(len=200) :: inputdir !< The directory in which to find input files @@ -146,9 +146,10 @@ module MOM_tidal_mixing type(remapping_CS) :: remap_CS !< The control structure for remapping ! Data containers - real, pointer, dimension(:,:) :: TKE_Niku => NULL() !< Lee wave driven Turbulent Kinetic Energy input [W m-2] + real, pointer, dimension(:,:) :: TKE_Niku => NULL() !< Lee wave driven Turbulent Kinetic Energy input + !! [kg Z3 m-3 T-3 ~> W m-2] real, pointer, dimension(:,:) :: TKE_itidal => NULL() !< The internal Turbulent Kinetic Energy input divided - !! by the bottom stratfication [J m-2]. + !! by the bottom stratfication [kg Z3 m-3 T-2 ~> J m-2]. real, pointer, dimension(:,:) :: Nb => NULL() !< The near bottom buoyancy frequency [s-1]. real, pointer, dimension(:,:) :: mask_itidal => NULL() !< A mask of where internal tide energy is input real, pointer, dimension(:,:) :: h2 => NULL() !< Squared bottom depth variance [m2]. @@ -260,8 +261,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".",do_not_log=.true.) CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", CS%int_tide_dissipation, & - "If true, use an internal tidal dissipation scheme to \n"//& - "drive diapycnal mixing, along the lines of St. Laurent \n"//& + "If true, use an internal tidal dissipation scheme to "//& + "drive diapycnal mixing, along the lines of St. Laurent "//& "et al. (2002) and Simmons et al. (2004).", default=CS%use_CVMix_tidal) ! return if tidal mixing is inactive @@ -273,7 +274,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ ! Read in CVMix tidal scheme if CVMix tidal mixing is on if (CS%use_CVMix_tidal) then call get_param(param_file, mdl, "CVMIX_TIDAL_SCHEME", CVMix_tidal_scheme_str, & - "CVMIX_TIDAL_SCHEME selects the CVMix tidal mixing\n"//& + "CVMIX_TIDAL_SCHEME selects the CVMix tidal mixing "//& "scheme with INT_TIDE_DISSIPATION. Valid values are:\n"//& "\t SIMMONS - Use the Simmons et al (2004) tidal \n"//& "\t mixing scheme.\n"//& @@ -294,11 +295,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ ! Read in vertical profile of tidal energy dissipation if ( CS%CVMix_tidal_scheme.eq.SCHMITTNER .or. .not. CS%use_CVMix_tidal) then call get_param(param_file, mdl, "INT_TIDE_PROFILE", int_tide_profile_str, & - "INT_TIDE_PROFILE selects the vertical profile of energy \n"//& + "INT_TIDE_PROFILE selects the vertical profile of energy "//& "dissipation with INT_TIDE_DISSIPATION. Valid values are:\n"//& "\t STLAURENT_02 - Use the St. Laurent et al exponential \n"//& "\t decay profile.\n"//& - "\t POLZIN_09 - Use the Polzin WKB-streched algebraic \n"//& + "\t POLZIN_09 - Use the Polzin WKB-stretched algebraic \n"//& "\t decay profile.", & default=STLAURENT_PROFILE_STRING) int_tide_profile_str = uppercase(int_tide_profile_str) @@ -318,9 +319,9 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ endif call get_param(param_file, mdl, "LEE_WAVE_DISSIPATION", CS%Lee_wave_dissipation, & - "If true, use an lee wave driven dissipation scheme to \n"//& - "drive diapycnal mixing, along the lines of Nikurashin \n"//& - "(2010) and using the St. Laurent et al. (2002) \n"//& + "If true, use an lee wave driven dissipation scheme to "//& + "drive diapycnal mixing, along the lines of Nikurashin "//& + "(2010) and using the St. Laurent et al. (2002) "//& "and Simmons et al. (2004) vertical profile", default=.false.) if (CS%lee_wave_dissipation) then if (CS%use_CVMix_tidal) then @@ -328,11 +329,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ "be used when CVMix tidal mixing scheme is active.") endif call get_param(param_file, mdl, "LEE_WAVE_PROFILE", tmpstr, & - "LEE_WAVE_PROFILE selects the vertical profile of energy \n"//& + "LEE_WAVE_PROFILE selects the vertical profile of energy "//& "dissipation with LEE_WAVE_DISSIPATION. Valid values are:\n"//& "\t STLAURENT_02 - Use the St. Laurent et al exponential \n"//& "\t decay profile.\n"//& - "\t POLZIN_09 - Use the Polzin WKB-streched algebraic \n"//& + "\t POLZIN_09 - Use the Polzin WKB-stretched algebraic \n"//& "\t decay profile.", & default=STLAURENT_PROFILE_STRING) tmpstr = uppercase(tmpstr) @@ -346,10 +347,10 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ endif call get_param(param_file, mdl, "INT_TIDE_LOWMODE_DISSIPATION", CS%Lowmode_itidal_dissipation, & - "If true, consider mixing due to breaking low modes that \n"//& - "have been remotely generated; as with itidal drag on the \n"//& - "barotropic tide, use an internal tidal dissipation scheme to \n"//& - "drive diapycnal mixing, along the lines of St. Laurent \n"//& + "If true, consider mixing due to breaking low modes that "//& + "have been remotely generated; as with itidal drag on the "//& + "barotropic tide, use an internal tidal dissipation scheme to "//& + "drive diapycnal mixing, along the lines of St. Laurent "//& "et al. (2002) and Simmons et al. (2004).", default=.false.) if ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & @@ -359,29 +360,29 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ "be used when CVMix tidal mixing scheme is active.") endif call get_param(param_file, mdl, "NU_POLZIN", CS%Nu_Polzin, & - "When the Polzin decay profile is used, this is a \n"//& - "non-dimensional constant in the expression for the \n"//& + "When the Polzin decay profile is used, this is a "//& + "non-dimensional constant in the expression for the "//& "vertical scale of decay for the tidal energy dissipation.", & units="nondim", default=0.0697) call get_param(param_file, mdl, "NBOTREF_POLZIN", CS%Nbotref_Polzin, & - "When the Polzin decay profile is used, this is the \n"//& - "Rreference value of the buoyancy frequency at the ocean \n"//& - "bottom in the Polzin formulation for the vertical \n"//& + "When the Polzin decay profile is used, this is the "//& + "reference value of the buoyancy frequency at the ocean "//& + "bottom in the Polzin formulation for the vertical "//& "scale of decay for the tidal energy dissipation.", & units="s-1", default=9.61e-4) call get_param(param_file, mdl, "POLZIN_DECAY_SCALE_FACTOR", & CS%Polzin_decay_scale_factor, & - "When the Polzin decay profile is used, this is a \n"//& - "scale factor for the vertical scale of decay of the tidal \n"//& + "When the Polzin decay profile is used, this is a "//& + "scale factor for the vertical scale of decay of the tidal "//& "energy dissipation.", default=1.0, units="nondim") call get_param(param_file, mdl, "POLZIN_SCALE_MAX_FACTOR", & CS%Polzin_decay_scale_max_factor, & - "When the Polzin decay profile is used, this is a factor \n"//& - "to limit the vertical scale of decay of the tidal \n"//& - "energy dissipation to POLZIN_DECAY_SCALE_MAX_FACTOR \n"//& + "When the Polzin decay profile is used, this is a factor "//& + "to limit the vertical scale of decay of the tidal "//& + "energy dissipation to POLZIN_DECAY_SCALE_MAX_FACTOR "//& "times the depth of the ocean.", units="nondim", default=1.0) call get_param(param_file, mdl, "POLZIN_MIN_DECAY_SCALE", CS%Polzin_min_decay_scale, & - "When the Polzin decay profile is used, this is the \n"//& + "When the Polzin decay profile is used, this is the "//& "minimum vertical decay scale for the vertical profile\n"//& "of internal tide dissipation with the Polzin (2009) formulation", & units="m", default=0.0, scale=US%m_to_Z) @@ -389,20 +390,20 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation) then call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE", CS%Int_tide_decay_scale, & - "The decay scale away from the bottom for tidal TKE with \n"//& + "The decay scale away from the bottom for tidal TKE with "//& "the new coding when INT_TIDE_DISSIPATION is used.", & !units="m", default=0.0) units="m", default=500.0, scale=US%m_to_Z) ! TODO: confirm this new default call get_param(param_file, mdl, "MU_ITIDES", CS%Mu_itides, & - "A dimensionless turbulent mixing efficiency used with \n"//& + "A dimensionless turbulent mixing efficiency used with "//& "INT_TIDE_DISSIPATION, often 0.2.", units="nondim", default=0.2) call get_param(param_file, mdl, "GAMMA_ITIDES", CS%Gamma_itides, & - "The fraction of the internal tidal energy that is \n"//& - "dissipated locally with INT_TIDE_DISSIPATION. \n"//& + "The fraction of the internal tidal energy that is "//& + "dissipated locally with INT_TIDE_DISSIPATION. "//& "THIS NAME COULD BE BETTER.", & units="nondim", default=0.3333) call get_param(param_file, mdl, "MIN_ZBOT_ITIDES", CS%min_zbot_itides, & - "Turn off internal tidal dissipation when the total \n"//& + "Turn off internal tidal dissipation when the total "//& "ocean depth is less than this value.", units="m", default=0.0, scale=US%m_to_Z) endif @@ -415,25 +416,25 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ call safe_alloc_ptr(CS%mask_itidal,isd,ied,jsd,jed) ; CS%mask_itidal(:,:) = 1.0 call get_param(param_file, mdl, "KAPPA_ITIDES", CS%kappa_itides, & - "A topographic wavenumber used with INT_TIDE_DISSIPATION. \n"//& + "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & units="m-1", default=8.e-4*atan(1.0), scale=US%Z_to_m) 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) call safe_alloc_ptr(CS%tideamp,is,ie,js,je) ; CS%tideamp(:,:) = CS%utide call get_param(param_file, mdl, "KAPPA_H2_FACTOR", CS%kappa_h2_factor, & - "A scaling factor for the roughness amplitude with n"//& + "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & - "The maximum internal tide energy source availble to mix \n"//& + "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3) + units="W m-2", default=1.0e3, scale=US%m_to_Z**3*US%T_to_s**3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & - "If true, read a file (given by TIDEAMP_FILE) containing \n"//& + "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) if (read_tideamp) then if (CS%use_CVMix_tidal) then @@ -441,15 +442,15 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ "not compatible with CVMix tidal mixing. ") endif call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & - "The path to the file containing the spatially varying \n"//& + "The path to the file containing the spatially varying "//& "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1) + call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & - "The path to the file containing the sub-grid-scale \n"//& + "The path to the file containing the sub-grid-scale "//& "topographic roughness amplitude with INT_TIDE_DISSIPATION.", & fail_if_missing=(.not.CS%use_CVMix_tidal)) filename = trim(CS%inputdir) // trim(h2_file) @@ -466,8 +467,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ CS%h2(i,j) = hamp*hamp utide = CS%tideamp(i,j) - ! Compute the fixed part of internal tidal forcing; units are [J m-2 = kg s-2] here. - CS%TKE_itidal(i,j) = 0.5*US%Z_to_m * CS%kappa_h2_factor*GV%Rho0*& + ! Compute the fixed part of internal tidal forcing; units are [kg Z3 m-3 T-2 ~> J m-2 = kg s-2] here. + CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%Rho0 * & CS%kappa_itides * CS%h2(i,j) * utide*utide enddo ; enddo @@ -476,11 +477,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ if (CS%Lee_wave_dissipation) then call get_param(param_file, mdl, "NIKURASHIN_TKE_INPUT_FILE",Niku_TKE_input_file, & - "The path to the file containing the TKE input from lee \n"//& + "The path to the file containing the TKE input from lee "//& "wave driven mixing. Used with LEE_WAVE_DISSIPATION.", & fail_if_missing=.true.) call get_param(param_file, mdl, "NIKURASHIN_SCALE",Niku_scale, & - "A non-dimensional factor by which to scale the lee-wave \n"//& + "A non-dimensional factor by which to scale the lee-wave "//& "driven TKE input. Used with LEE_WAVE_DISSIPATION.", & units="nondim", default=1.0) @@ -488,15 +489,16 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ call log_param(param_file, mdl, "INPUTDIR/NIKURASHIN_TKE_INPUT_FILE", & filename) call safe_alloc_ptr(CS%TKE_Niku,is,ie,js,je) ; CS%TKE_Niku(:,:) = 0.0 - call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1 ) ! ??? timelevel -aja + call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja + scale=US%m_to_Z**3*US%T_to_s**3) CS%TKE_Niku(:,:) = Niku_scale * CS%TKE_Niku(:,:) call get_param(param_file, mdl, "GAMMA_NIKURASHIN",CS%Gamma_lee, & - "The fraction of the lee wave energy that is dissipated \n"//& + "The fraction of the lee wave energy that is dissipated "//& "locally with LEE_WAVE_DISSIPATION.", units="nondim", & default=0.3333) call get_param(param_file, mdl, "DECAY_SCALE_FACTOR_LEE",CS%Decay_scale_factor_lee, & - "Scaling for the vertical decay scaleof the local \n"//& + "Scaling for the vertical decay scaleof the local "//& "dissipation of lee waves dissipation.", units="nondim", & default=1.0) else @@ -512,17 +514,17 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ "largest acceptable value for tidal diffusivity", & units="m^2/s", default=50e-4) ! the default is 50e-4 in CVMix, 100e-4 in POP. call get_param(param_file, mdl, "TIDAL_DISS_LIM_TC", CS%tidal_diss_lim_tc, & - "Min allowable depth for dissipation for tidal-energy-constituent data. \n"//& + "Min allowable depth for dissipation for tidal-energy-constituent data. "//& "No dissipation contribution is applied above TIDAL_DISS_LIM_TC.", & units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "TIDAL_ENERGY_FILE",tidal_energy_file, & - "The path to the file containing tidal energy \n"//& + "The path to the file containing tidal energy "//& "dissipation. Used with CVMix tidal mixing schemes.", & fail_if_missing=.true.) call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, & do_not_log=.True.) call get_param(param_file, mdl, "PRANDTL_TIDAL", prandtl_tidal, & - "Prandtl number used by CVMix tidal mixing schemes \n"//& + "Prandtl number used by CVMix tidal mixing schemes "//& "to convert vertical diffusivities into viscosities.", & units="nondim", default=1.0, & do_not_log=.true.) @@ -582,21 +584,25 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ else CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal',diag%axesT1,Time, & - 'Internal Tide Driven Turbulent Kinetic Energy', 'W m-2') + 'Internal Tide Driven Turbulent Kinetic Energy', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Nb = register_diag_field('ocean_model','Nb',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1') CS%id_Kd_lowmode = register_diag_field('ocean_model','Kd_lowmode',diag%axesTi,Time, & - 'Internal Tide Driven Diffusivity (from propagating low modes)', 'm2 s-1', conversion=US%Z_to_m**2) + 'Internal Tide Driven Diffusivity (from propagating low modes)', & + 'm2 s-1', conversion=US%Z_to_m**2) CS%id_Fl_itidal = register_diag_field('ocean_model','Fl_itides',diag%axesTi,Time, & - 'Vertical flux of tidal turbulent dissipation', 'm3 s-3') + 'Vertical flux of tidal turbulent dissipation', & + 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Fl_lowmode = register_diag_field('ocean_model','Fl_lowmode',diag%axesTi,Time, & - 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', 'm3 s-3') + 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', & + 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale',diag%axesT1,Time, & - 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', 'm', conversion=US%Z_to_m) + 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', & + 'm', conversion=US%Z_to_m) CS%id_Polzin_decay_scale_scaled = register_diag_field('ocean_model', & 'Polzin_decay_scale_scaled', diag%axesT1, Time, & @@ -610,17 +616,18 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ 'Buoyancy frequency squared averaged over the water column', 's-2') CS%id_Kd_Itidal_Work = register_diag_field('ocean_model','Kd_Itidal_Work',diag%axesTL,Time, & - 'Work done by Internal Tide Diapycnal Mixing', 'W m-2') + 'Work done by Internal Tide Diapycnal Mixing', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Kd_Niku_Work = register_diag_field('ocean_model','Kd_Nikurashin_Work',diag%axesTL,Time, & - 'Work done by Nikurashin Lee Wave Drag Scheme', 'W m-2') + 'Work done by Nikurashin Lee Wave Drag Scheme', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Kd_Lowmode_Work = register_diag_field('ocean_model','Kd_Lowmode_Work',diag%axesTL,Time, & - 'Work done by Internal Tide Diapycnal Mixing (low modes)', 'W m-2') + 'Work done by Internal Tide Diapycnal Mixing (low modes)', & + 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) if (CS%Lee_wave_dissipation) then CS%id_TKE_leewave = register_diag_field('ocean_model','TKE_leewave',diag%axesT1,Time, & - 'Lee wave Driven Turbulent Kinetic Energy', 'W m-2') + 'Lee wave Driven Turbulent Kinetic Energy', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Kd_Niku = register_diag_field('ocean_model','Kd_Nikurashin',diag%axesTi,Time, & 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=US%Z_to_m**2) endif @@ -659,28 +666,28 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy - !! frequency [s-2]. + !! frequency [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the - !! layers [s-2]. + !! layers [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int !< The squared buoyancy frequency at the - !! interfaces [s-2]. + !! interfaces [T-2 ~> s-2]. integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE - !! TKE dissipated within a layer and the - !! diapycnal diffusivity witin that layer, + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [m3 s-3] + !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), pointer :: CS !< The control structure for this module real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 s-1 ~> m2 s-1]. + intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. !! Set this to a negative value to have no limit. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 s-1 ~> m2 s-1]. @@ -689,8 +696,8 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C if (CS%use_CVMix_tidal) then call calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) else - call add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, CS, & - N2_lay, Kd_lay, Kd_int, Kd_max) + call add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, & + G, GV, US, CS, N2_lay, Kd_lay, Kd_int, US%s_to_T*Kd_max) endif endif end subroutine calculate_tidal_mixing @@ -705,11 +712,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tidal_mixing_cs), pointer :: CS !< This module's control structure. real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int !< The squared buoyancy - !! frequency at the interfaces [s-2]. + !! frequency at the interfaces [T-2 ~> s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay!< The diapycnal diffusivities in the layers [Z2 s-1 ~> m2 s-1]. + intent(inout) :: Kd_lay!< The diapycnal diffusivities in the layers [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 s-1 ~> m2 s-1]. ! Local variables @@ -721,6 +728,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) real, dimension(SZK_(G)) :: cellHeight ! Height of cell centers [m] real, dimension(SZK_(G)) :: tidal_qe_md ! Tidal dissipation energy interpolated from 3d input ! to model coordinates + real, dimension(SZK_(G)+1) :: N2_int_i ! De-scaled interface buoyancy frequency [s-2] real, dimension(SZK_(G)) :: Schmittner_coeff real, dimension(SZK_(G)) :: h_m ! Cell thickness [m] real, allocatable, dimension(:,:) :: exp_hab_zetar @@ -768,9 +776,14 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) Simmons_coeff = Simmons_coeff / CS%Gamma_itides + ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable + do k = 1,G%ke+1 + N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) + enddo + call CVMix_coeffs_tidal( Mdiff_out = Kv_tidal, & Tdiff_out = Kd_tidal, & - Nsqr = N2_int(i,:), & + Nsqr = N2_int_i, & OceanDepth = -iFaceHeight(G%ke+1),& SimmonsCoeff = Simmons_coeff, & vert_dep = vert_dep, & @@ -781,7 +794,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) ! Update diffusivity do k=1,G%ke - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*US%m_to_Z**2*(Kd_tidal(k) + Kd_tidal(k+1)) ! Rescale from m2 s-1 to Z2 s-1. + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo ! Update viscosity with the proper unit conversion. @@ -864,10 +877,14 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) exp_hab_zetar = exp_hab_zetar, & CVmix_tidal_params_user = CS%CVMix_tidal_params) + ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable + do k = 1,G%ke+1 + N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) + enddo call CVMix_coeffs_tidal_schmittner( Mdiff_out = Kv_tidal, & Tdiff_out = Kd_tidal, & - Nsqr = N2_int(i,:), & + Nsqr = N2_int_i, & OceanDepth = -iFaceHeight(G%ke+1), & vert_dep = vert_dep, & nlev = G%ke, & @@ -879,7 +896,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) ! Update diffusivity do k=1,G%ke - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*US%m_to_Z**2*(Kd_tidal(k) + Kd_tidal(k+1)) ! Rescale from m2 s-1 to Z2 s-1. + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo ! Update viscosity @@ -931,23 +948,23 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy frequency - !! frequency [s-2]. + !! frequency [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the - !! layers [s-2]. + !! layers [T-2 ~> s-2]. integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE - !! TKE dissipated within a layer and the - !! diapycnal diffusivity witin that layer, + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [m3 s-3] + !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), pointer :: CS !< The control structure for this module real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 s-1 ~> m2 s-1]. + intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes !! [Z2 s-1 ~> m2 s-1]. @@ -959,9 +976,9 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, htot, & ! total thickness above or below a layer, or the ! integrated thickness in the BBL [Z ~> m]. htot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m]. - TKE_itidal_bot, & ! internal tide TKE at ocean bottom [m3 s-3] - TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [m3 s-3] - TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [m3 s-3] (BDM) + TKE_itidal_bot, & ! internal tide TKE at ocean bottom [Z3 T-3 ~> m3 s-3] + TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [Z3 T-3 ~> m3 s-3] + TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [Z3 T-3 ~> m3 s-3] (BDM) Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] (BDM) @@ -971,9 +988,9 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, ! z*=int(N2/N2_bot) * N2_bot/N2_meanz = int(N2/N2_meanz) ! z0_Polzin_scaled = z0_Polzin * N2_bot/N2_meanz N2_meanz, & ! vertically averaged squared buoyancy frequency [s-2] for WKB scaling - TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) - TKE_Niku_rem, & ! remaining lee-wave TKE - TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) (BDM) + TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) [Z3 T-3 ~> m3 s-3] + TKE_Niku_rem, & ! remaining lee-wave TKE [Z3 T-3 ~> m3 s-3] + TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) [Z3 T-3 ~> m3 s-3] (BDM) TKE_frac_top, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lowmode, & @@ -983,14 +1000,14 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, real :: I_rho0 ! 1 / RHO0 [m3 kg-1] real :: Kd_add ! diffusivity to add in a layer [Z2 s-1 ~> m2 s-1]. - real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [m3 s-3] - real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [m3 s-3] - real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [m3 s-3] (BDM) + real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [Z3 T-3 ~> m3 s-3] + real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [Z3 T-3 ~> m3 s-3] + real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [Z3 T-3 ~> m3 s-3] (BDM) real :: frac_used ! fraction of TKE that can be used in a layer [nondim] real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1]. real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1]. real :: z0_psl ! temporary variable [Z ~> m]. - real :: TKE_lowmode_tot ! TKE from all low modes [W m-2] (BDM) + real :: TKE_lowmode_tot ! TKE from all low modes [kg Z3 m-3 T-3 ~> W m-2] (BDM) logical :: use_Polzin, use_Simmons character(len=160) :: mesg ! The text of an error message @@ -1024,8 +1041,8 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, & GV%H_subroundoff*GV%H_to_Z) do i=is,ie - CS%Nb(i,j) = sqrt(N2_bot(i)) - if (associated(dd%N2_bot)) dd%N2_bot(i,j) = N2_bot(i) + CS%Nb(i,j) = sqrt(US%s_to_T**2 * N2_bot(i)) + if (associated(dd%N2_bot)) dd%N2_bot(i,j) = US%s_to_T**2 * N2_bot(i) if ( CS%Int_tide_dissipation ) then if (Izeta*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. Inv_int(i) = 1.0 / (1.0 - exp(-Izeta*htot(i))) @@ -1050,7 +1067,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, ! WKB scaling of the vertical coordinate do i=is,ie ; N2_meanz(i)=0.0 ; enddo do k=1,nz ; do i=is,ie - N2_meanz(i) = N2_meanz(i) + N2_lay(i,k)*GV%H_to_Z*h(i,j,k) + N2_meanz(i) = N2_meanz(i) + (US%s_to_T**2 * N2_lay(i,k)) * GV%H_to_Z * h(i,j,k) enddo ; enddo do i=is,ie N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%H_subroundoff*GV%H_to_Z) @@ -1061,18 +1078,18 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, do i=is,ie ; htot_WKB(i) = htot(i) ; enddo ! do i=is,ie ; htot_WKB(i) = 0.0 ; enddo ! do k=1,nz ; do i=is,ie -! htot_WKB(i) = htot_WKB(i) + GV%H_to_Z*h(i,j,k)*N2_lay(i,k) / N2_meanz(i) +! htot_WKB(i) = htot_WKB(i) + GV%H_to_Z*h(i,j,k) * (US%s_to_T**2 * N2_lay(i,k)) / N2_meanz(i) ! enddo ; enddo ! htot_WKB(i) = htot(i) ! Nearly equivalent and simpler do i=is,ie - CS%Nb(i,j) = sqrt(N2_bot(i)) + CS%Nb(i,j) = sqrt(US%s_to_T**2 * N2_bot(i)) !### In the code below 1.0e-14 is a dimensional constant in [s-3] if ((CS%tideamp(i,j) > 0.0) .and. & (CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 > 1.0e-14) ) then - z0_polzin(i) = US%m_to_Z * CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & + z0_polzin(i) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & CS%Nbotref_Polzin**2 * CS%tideamp(i,j) / & - ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 ) + ( CS%kappa_itides**2 * CS%h2(i,j) * US%T_to_s * CS%Nb(i,j)**3 ) if (z0_polzin(i) < CS%Polzin_min_decay_scale) & z0_polzin(i) = CS%Polzin_min_decay_scale if (N2_meanz(i) > 1.0e-14 ) then !### Here 1.0e-14 has dimensions of s-2. @@ -1118,7 +1135,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, z_from_bot(i) = GV%H_to_Z*h(i,j,nz) ! Use the new formulation for WKB scaling. N2 is referenced to its vertical mean. if (N2_meanz(i) > 1.0e-14 ) then !### Avoid using this dimensional constant. - z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz)*N2_lay(i,nz) / N2_meanz(i) + z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz) * (US%s_to_T**2 * N2_lay(i,nz)) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif enddo endif ! Polzin @@ -1127,7 +1144,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, ! Both Polzin and Simmons: do i=is,ie ! Dissipation of locally trapped internal tide (non-propagating high modes) - TKE_itidal_bot(i) = min(CS%TKE_itidal(i,j)*CS%Nb(i,j),CS%TKE_itide_max) + TKE_itidal_bot(i) = min(CS%TKE_itidal(i,j)*US%T_to_s*CS%Nb(i,j), CS%TKE_itide_max) if (associated(dd%TKE_itidal_used)) & dd%TKE_itidal_used(i,j) = TKE_itidal_bot(i) TKE_itidal_bot(i) = (I_rho0 * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) @@ -1176,8 +1193,8 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)* TKE_frac_top_lowmode(i) ! Actual power expended may be less than predicted if stratification is weak; adjust - if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then - frac_used = max_TKE(i,k) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > (max_TKE(i,k))) then + frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay TKE_lowmode_lay = frac_used * TKE_lowmode_lay @@ -1189,21 +1206,21 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = US%s_to_T * TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add + Kd_lay(i,j,k) = Kd_lay(i,j,k) + (US%T_to_s * Kd_add) if (present(Kd_int)) then - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*Kd_add - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*Kd_add + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * (US%T_to_s * Kd_add) + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * (US%T_to_s * Kd_add) endif ! diagnostics if (associated(dd%Kd_itidal)) then ! If at layers, dd%Kd_itidal is just TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + Kd_add = US%s_to_T * TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_itidal(i,j,K) = dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_Niku(i,j,K) = dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_lowmode(i,j,K) = dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k 1.0e-14 ) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) + GV%H_to_Z*h(i,j,k)*N2_lay(i,k)/N2_meanz(i) + z_from_bot_WKB(i) = z_from_bot_WKB(i) & + + GV%H_to_Z * h(i,j,k) * (US%s_to_T**2 * N2_lay(i,k)) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif ! Fraction of bottom flux predicted to reach top of this layer @@ -1263,8 +1281,8 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)*TKE_frac_top_lowmode(i) ! Actual power expended may be less than predicted if stratification is weak; adjust - if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then - frac_used = max_TKE(i,k) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > (max_TKE(i,k))) then + frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay TKE_lowmode_lay = frac_used * TKE_lowmode_lay @@ -1276,21 +1294,21 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = US%s_to_T * TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add + Kd_lay(i,j,k) = Kd_lay(i,j,k) + (US%T_to_s * Kd_add) if (present(Kd_int)) then - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*Kd_add - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*Kd_add + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * (US%T_to_s * Kd_add) + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * (US%T_to_s * Kd_add) endif ! diagnostics if (associated(dd%Kd_itidal)) then ! If at layers, this is just dd%Kd_itidal(i,j,K) = TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + Kd_add = US%s_to_T * TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_itidal(i,j,K) = dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_Niku(i,j,K) = dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_lowmode(i,j,K) = dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k Pa] real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to rock [Pa] + optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to rock [kg Z s-2 m-2 ~> Pa] type(wave_parameters_CS), & optional, pointer :: Waves !< Container for wave/Stokes information @@ -669,7 +669,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) allocate(CS%a1_shelf_v(G%isd:G%ied,G%JsdB:G%JedB)) ; CS%a1_shelf_v(:,:)=0.0 endif - !$OMP parallel do default(private) shared(G,GV,CS,visc,Isq,Ieq,nz,u,h,forces,hML_u, & + !$OMP parallel do default(private) shared(G,GV,US,CS,visc,Isq,Ieq,nz,u,h,forces,hML_u, & !$OMP OBC,h_neglect,dt,I_valBL,Kv_u) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec @@ -836,7 +836,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) ! Now work on v-points. - !$OMP parallel do default(private) shared(G,GV,CS,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & + !$OMP parallel do default(private) shared(G,GV,CS,US,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & !$OMP OBC,h_neglect,dt,I_valBL,Kv_v) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq @@ -1292,11 +1292,11 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, if (GV%nkml>0) nk_visc(i) = real(GV%nkml+1) if (work_on_u) then u_star(I) = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) - absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + absf(I) = 0.5*US%s_to_T*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) if (CS%dynamic_viscous_ML) nk_visc(I) = visc%nkml_visc_u(I,j) + 1 else u_star(i) = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) - absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + absf(i) = 0.5*US%s_to_T*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) if (CS%dynamic_viscous_ML) nk_visc(i) = visc%nkml_visc_v(i,J) + 1 endif h_ml(i) = h_neglect ; z_t(i) = 0.0 @@ -1603,110 +1603,110 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! Default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & - "If true, the bottom stress is calculated with a drag \n"//& - "law of the form c_drag*|u|*u. The velocity magnitude \n"//& - "may be an assumed value or it may be based on the \n"//& - "actual velocity in the bottommost HBBL, depending on \n"//& + "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.", default=.true.) call get_param(param_file, mdl, "CHANNEL_DRAG", CS%Channel_drag, & - "If true, the bottom drag is exerted directly on each \n"//& - "layer proportional to the fraction of the bottom it \n"//& + "If true, the bottom drag is exerted directly on each "//& + "layer proportional to the fraction of the bottom it "//& "overlies.", default=.false.) call get_param(param_file, mdl, "DIRECT_STRESS", CS%direct_stress, & - "If true, the wind stress is distributed over the \n"//& - "topmost HMIX_STRESS of fluid (like in HYCOM), and KVML \n"//& + "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.", default=.false.) call get_param(param_file, mdl, "DYNAMIC_VISCOUS_ML", CS%dynamic_viscous_ML, & - "If true, use a bulk Richardson number criterion to \n"//& + "If true, use a bulk Richardson number criterion to "//& "determine the mixed layer thickness for viscosity.", & default=.false.) call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & - "The absolute path to a file into which the accelerations \n"//& - "leading to zonal velocity truncations are written. \n"//& - "Undefine this for efficiency if this diagnostic is not \n"//& + "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.", default=" ", debuggingParam=.true.) call get_param(param_file, mdl, "V_TRUNC_FILE", CS%v_trunc_file, & - "The absolute path to a file into which the accelerations \n"//& - "leading to meridional velocity truncations are written. \n"//& - "Undefine this for efficiency if this diagnostic is not \n"//& + "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.", default=" ", debuggingParam=.true.) call get_param(param_file, mdl, "HARMONIC_VISC", CS%harmonic_visc, & - "If true, use the harmonic mean thicknesses for \n"//& + "If true, use the harmonic mean thicknesses for "//& "calculating the vertical viscosity.", default=.false.) call get_param(param_file, mdl, "HARMONIC_BL_SCALE", CS%harm_BL_val, & - "A scale to determine when water is in the boundary \n"//& - "layers based solely on harmonic mean thicknesses for \n"//& - "the purpose of determining the extent to which the \n"//& + "A scale to determine when water is in the boundary "//& + "layers based solely on harmonic mean thicknesses for "//& + "the purpose of determining the extent to which the "//& "thicknesses used in the viscosities are upwinded.", & default=0.0, units="nondim") call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) if (GV%nkml < 1) & call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & - "The prescribed depth over which the near-surface \n"//& - "viscosity and diffusivity are elevated when the bulk \n"//& + "The prescribed depth over which the near-surface "//& + "viscosity and diffusivity are elevated when the bulk "//& "mixed layer is not used.", units="m", scale=GV%m_to_H, & unscaled=Hmix_m, fail_if_missing=.true.) if (CS%direct_stress) then if (GV%nkml < 1) then call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & - "The depth over which the wind stress is applied if \n"//& + "The depth over which the wind stress is applied if "//& "DIRECT_STRESS is true.", units="m", default=Hmix_m, scale=GV%m_to_H) else call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & - "The depth over which the wind stress is applied if \n"//& + "The depth over which the wind stress is applied if "//& "DIRECT_STRESS is true.", units="m", fail_if_missing=.true., scale=GV%m_to_H) endif if (CS%Hmix_stress <= 0.0) call MOM_error(FATAL, "vertvisc_init: " // & "HMIX_STRESS must be set to a positive value if DIRECT_STRESS is true.") endif call get_param(param_file, mdl, "KV", CS%Kv, & - "The background kinematic viscosity in the interior. \n"//& + "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true., scale=US%m_to_Z**2, unscaled=Kv_dflt) if (GV%nkml < 1) call get_param(param_file, mdl, "KVML", CS%Kvml, & - "The kinematic viscosity in the mixed layer. A typical \n"//& - "value is ~1e-2 m2 s-1. KVML is not used if \n"//& + "The kinematic viscosity in the mixed layer. A typical "//& + "value is ~1e-2 m2 s-1. KVML is not used if "//& "BULKMIXEDLAYER is true. The default is set by KV.", & units="m2 s-1", default=Kv_dflt, scale=US%m_to_Z**2) if (.not.CS%bottomdraglaw) call get_param(param_file, mdl, "KVBBL", CS%Kvbbl, & - "The kinematic viscosity in the benthic boundary layer. \n"//& - "A typical value is ~1e-2 m2 s-1. KVBBL is not used if \n"//& + "The kinematic viscosity in the benthic boundary layer. "//& + "A typical value is ~1e-2 m2 s-1. KVBBL is not used if "//& "BOTTOMDRAGLAW is true. The default is set by KV.", & units="m2 s-1", default=Kv_dflt, scale=US%m_to_Z**2) call get_param(param_file, mdl, "HBBL", CS%Hbbl, & - "The thickness of a bottom boundary layer with a \n"//& - "viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or \n"//& - "the thickness over which near-bottom velocities are \n"//& - "averaged for the drag law if BOTTOMDRAGLAW is defined \n"//& + "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.", units="m", fail_if_missing=.true., scale=GV%m_to_H) call get_param(param_file, mdl, "MAXVEL", CS%maxvel, & - "The maximum velocity allowed before the velocity \n"//& + "The maximum velocity allowed before the velocity "//& "components are truncated.", units="m s-1", default=3.0e8) call get_param(param_file, mdl, "CFL_BASED_TRUNCATIONS", CS%CFL_based_trunc, & - "If true, base truncations on the CFL number, and not an \n"//& + "If true, base truncations on the CFL number, and not an "//& "absolute speed.", default=.true.) call get_param(param_file, mdl, "CFL_TRUNCATE", CS%CFL_trunc, & - "The value of the CFL number that will cause velocity \n"//& + "The value of the CFL number that will cause velocity "//& "components to be truncated; instability can occur past 0.5.", & units="nondim", default=0.5) call get_param(param_file, mdl, "CFL_REPORT", CS%CFL_report, & - "The value of the CFL number that causes accelerations \n"//& + "The value of the CFL number that causes accelerations "//& "to be reported; the default is CFL_TRUNCATE.", & units="nondim", default=CS%CFL_trunc) call get_param(param_file, mdl, "CFL_TRUNCATE_RAMP_TIME", CS%truncRampTime, & - "The time over which the CFL trunction value is ramped\n"//& + "The time over which the CFL truncation value is ramped "//& "up at the beginning of the run.", & units="s", default=0.) CS%CFL_truncE = CS%CFL_trunc call get_param(param_file, mdl, "CFL_TRUNCATE_START", CS%CFL_truncS, & - "The start value of the truncation CFL number used when\n"//& + "The start value of the truncation CFL number used when "//& "ramping up CFL_TRUNC.", & units="nondim", default=0.) call get_param(param_file, mdl, "STOKES_MIXING_COMBINED", CS%StokesMixing, & - "Flag to use Stokes drift Mixing via the Lagrangian \n"//& - " current (Eulerian plus Stokes drift). \n"//& + "Flag to use Stokes drift Mixing via the Lagrangian "//& + " current (Eulerian plus Stokes drift). "//& " Still needs work and testing, so not recommended for use.",& Default=.false.) !BGR 04/04/2018{ @@ -1719,14 +1719,14 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! MOM_error to use, but do so at your own risk and with these points in mind. !} if (CS%StokesMixing) then - call MOM_error(FATAL, "Stokes mixing requires user interfention in the code.\n"//& - " Model now exiting. See MOM_vert_friction.F90 for \n"//& + call MOM_error(FATAL, "Stokes mixing requires user intervention in the code.\n"//& + " Model now exiting. See MOM_vert_friction.F90 for \n"//& " details (search 'BGR 04/04/2018' to locate comment).") endif call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & - "A negligibly small velocity magnitude below which velocity \n"//& - "components are set to 0. A reasonable value might be \n"//& - "1e-30 m/s, which is less than an Angstrom divided by \n"//& + "A negligibly small velocity magnitude below which velocity "//& + "components are set to 0. A reasonable value might be "//& + "1e-30 m/s, which is less than an Angstrom divided by "//& "the age of the universe.", units="m s-1", default=0.0) ALLOC_(CS%a_u(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u(:,:,:) = 0.0 @@ -1769,9 +1769,11 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & if (CS%id_dv_dt_visc > 0) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) CS%id_taux_bot = register_diag_field('ocean_model', 'taux_bot', diag%axesCu1, & - Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa') + Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa', & + conversion=US%Z_to_m) CS%id_tauy_bot = register_diag_field('ocean_model', 'tauy_bot', diag%axesCv1, & - Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa') + Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & + conversion=US%Z_to_m) if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & call PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS%PointAccel_CSp) diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 45eebb983e..90e59269d7 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -93,8 +93,8 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DOME_TRACER_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the DOME tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the DOME tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -104,8 +104,8 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%tracer_IC_file) endif call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 36bc3edb65..deb5a78bea 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -97,8 +97,8 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ISOMIP_TRACER_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the ISOMIP tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the ISOMIP tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -108,8 +108,8 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%tracer_IC_file) endif call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 805409c16b..43fe728d04 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -140,7 +140,7 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "CFC_IC_FILE", CS%IC_file, & - "The file in which the CFC initial values can be \n"//& + "The file in which the CFC initial values can be "//& "found, or an empty string for internal initialization.", & default=" ") if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then @@ -153,9 +153,9 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) "If true, CFC_IC_FILE is in depth space, not layer space", & default=.false.) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if tracers are not found in the "//& "restart files of a restarted run.", default=.false.) ! The following vardesc types contain a package of metadata about each tracer, diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 93f72b239d..adfd60f664 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -134,7 +134,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, sub_name, version, "") call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE", CS%IC_file, & - "The file in which the generic trcer initial values can \n"//& + "The file in which the generic trcer initial values can "//& "be found, or an empty string for internal initialization.", & default=" ") if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then @@ -144,12 +144,12 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call log_param(param_file, sub_name, "INPUTDIR/GENERIC_TRACER_IC_FILE", CS%IC_file) endif call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE_IS_Z", CS%Z_IC_file, & - "If true, GENERIC_TRACER_IC_FILE is in depth space, not \n"//& + "If true, GENERIC_TRACER_IC_FILE is in depth space, not "//& "layer space.",default=.false.) call get_param(param_file, sub_name, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if tracers are not found in the "//& "restart files of a restarted run.", default=.false.) CS%restart_CSp => restart_CS @@ -303,7 +303,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, enddo ; enddo ; enddo !jgj: Reset CASED to 0 below K=1 - if (trim(g_tracer_name) == 'cased') then + if ( (trim(g_tracer_name) == 'cased') .or. (trim(g_tracer_name) == 'ca13csed') ) then do k=2,nk ; do j=jsc,jec ; do i=isc,iec if (tr_ptr(i,j,k) /= CS%tracer_land_val) then tr_ptr(i,j,k) = 0.0 diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index e692157778..bfa499b818 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -137,54 +137,54 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "NDIFF_CONTINUOUS", CS%continuous_reconstruction, & - "If true, uses a continuous reconstruction of T and S when \n"// & - "finding neutral surfaces along which diffusion will happen.\n"// & - "If false, a PPM discontinuous reconstruction of T and S \n"// & - "is done which results in a higher order routine but exacts \n"// & + "If true, uses a continuous reconstruction of T and S when "//& + "finding neutral surfaces along which diffusion will happen. "//& + "If false, a PPM discontinuous reconstruction of T and S "//& + "is done which results in a higher order routine but exacts "//& "a higher computational cost.", default=.true.) call get_param(param_file, mdl, "NDIFF_REF_PRES", CS%ref_pres, & - "The reference pressure (Pa) used for the derivatives of \n"// & - "the equation of state. If negative (default), local \n"// & + "The reference pressure (Pa) used for the derivatives of "//& + "the equation of state. If negative (default), local "//& "pressure is used.", & default = -1.) ! Initialize and configure remapping if (CS%continuous_reconstruction .eqv. .false.) then call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & - "Uses a rootfinding approach to find the position of a\n"// & - "neutral surface within a layer taking into account the\n"// & - "nonlinearity of the equation of state and the\n"// & + "Uses a rootfinding approach to find the position of a "//& + "neutral surface within a layer taking into account the "//& + "nonlinearity of the equation of state and the "//& "polynomial reconstructions of T/S.", & default=.false.) call get_param(param_file, mdl, "NDIFF_REMAPPING_SCHEME", string, & - "This sets the reconstruction scheme used\n"//& - "for vertical remapping for all variables.\n"//& - "It can be one of the following schemes:\n"//& + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "NDIFF_REFINE_POSITION", CS%refine_position, & - "Uses a rootfinding approach to find the position of a\n"// & - "neutral surface within a layer taking into account the\n"// & - "nonlinearity of the equation of state and the\n"// & + "Uses a rootfinding approach to find the position of a "//& + "neutral surface within a layer taking into account the "//& + "nonlinearity of the equation of state and the "//& "polynomial reconstructions of T/S.", & default=.false.) if (CS%refine_position) then call get_param(param_file, mdl, "NDIFF_DRHO_TOL", drho_tol, & - "Sets the convergence criterion for finding the neutral\n"// & + "Sets the convergence criterion for finding the neutral "//& "position within a layer in kg m-3.", & default=1.e-10) call get_param(param_file, mdl, "NDIFF_X_TOL", xtol, & - "Sets the convergence criterion for a change in nondim\n"// & + "Sets the convergence criterion for a change in nondim "//& "position within a layer.", & default=0.) call get_param(param_file, mdl, "NDIFF_MAX_ITER", max_iter, & - "The maximum number of iterations to be done before \n"// & + "The maximum number of iterations to be done before "//& "exiting the iterative loop to find the neutral surface", & default=10) call set_ndiff_aux_params(CS%ndiff_aux_CS, max_iter = max_iter, drho_tol = drho_tol, xtol = xtol) endif call get_param(param_file, mdl, "NDIFF_DEBUG", CS%debug, & - "Turns on verbose output for discontinuous neutral \n"// & + "Turns on verbose output for discontinuous neutral "//& "diffusion routines.", & default = .false.) call set_ndiff_aux_params(CS%ndiff_aux_CS, deg=CS%deg, ref_pres = CS%ref_pres, EOS = EOS, debug = CS%debug) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index a4676583bd..00b61210fe 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -1313,27 +1313,27 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV) call get_param(param_file, mdl, "DT_OFFLINE", CS%dt_offline, & "Length of time between reading in of input fields", fail_if_missing = .true.) call get_param(param_file, mdl, "DT_OFFLINE_VERTICAL", CS%dt_offline_vertical, & - "Length of the offline timestep for tracer column sources/sinks\n" //& - "This should be set to the length of the coupling timestep for \n" //& + "Length of the offline timestep for tracer column sources/sinks " //& + "This should be set to the length of the coupling timestep for " //& "tracers which need shortwave fluxes", fail_if_missing = .true.) call get_param(param_file, mdl, "START_INDEX", CS%start_index, & "Which time index to start from", default=1) call get_param(param_file, mdl, "FIELDS_ARE_OFFSET", CS%fields_are_offset, & - "True if the time-averaged fields and snapshot fields\n"//& + "True if the time-averaged fields and snapshot fields "//& "are offset by one time level", default=.false.) call get_param(param_file, mdl, "REDISTRIBUTE_METHOD", redistribute_method, & - "Redistributes any remaining horizontal fluxes throughout\n" //& - "the rest of water column. Options are 'barotropic' which\n" //& - "evenly distributes flux throughout the entire water column,\n" //& - "'upwards' which adds the maximum of the remaining flux in\n" //& - "each layer above, both which first applies upwards and then\n" //& + "Redistributes any remaining horizontal fluxes throughout " //& + "the rest of water column. Options are 'barotropic' which " //& + "evenly distributes flux throughout the entire water column, " //& + "'upwards' which adds the maximum of the remaining flux in " //& + "each layer above, both which first applies upwards and then " //& "barotropic, and 'none' which does no redistribution", & default='barotropic') call get_param(param_file, mdl, "NUM_OFF_ITER", CS%num_off_iter, & "Number of iterations to subdivide the offline tracer advection and diffusion", & default = 60) call get_param(param_file, mdl, "OFF_ALE_MOD", CS%off_ale_mod, & - "Sets how many horizontal advection steps are taken before an ALE\n" //& + "Sets how many horizontal advection steps are taken before an ALE " //& "remapping step is done. 1 would be x->y->ALE, 2 would be" //& "x->y->x->y->ALE", default = 1) call get_param(param_file, mdl, "PRINT_ADV_OFFLINE", CS%print_adv_offline, & @@ -1350,21 +1350,21 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV) "Name of the variable containing the depth of active mixing",& default='ePBL_h_ML') call get_param(param_file, mdl, "OFFLINE_ADD_DIURNAL_SW", CS%diurnal_sw, & - "Adds a synthetic diurnal cycle in the same way that the ice\n" // & - "model would have when time-averaged fields of shortwave\n" // & + "Adds a synthetic diurnal cycle in the same way that the ice " // & + "model would have when time-averaged fields of shortwave " // & "radiation are read in", default=.false.) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & - "The maximum permitted increment for the diapycnal \n"//& - "diffusivity from TKE-based parameterizations, or a \n"//& + "The maximum permitted increment for the diapycnal "//& + "diffusivity from TKE-based parameterizations, or a "//& "negative value for no limit.", units="m2 s-1", default=-1.0) call get_param(param_file, mdl, "MIN_RESIDUAL_TRANSPORT", CS%min_residual, & - "How much remaining transport before the main offline advection\n"// & - "is exited. The default value corresponds to about 1 meter of\n" // & + "How much remaining transport before the main offline advection "// & + "is exited. The default value corresponds to about 1 meter of " // & "difference in a grid cell", default = 1.e9) call get_param(param_file, mdl, "READ_ALL_TS_UVH", CS%read_all_ts_uvh, & - "Reads all time levels of a subset of the fields necessary to run \n" // & - "the model offline. This can require a large amount of memory\n"// & - "and will make initialization very slow. However, for offline\n"// & + "Reads all time levels of a subset of the fields necessary to run " // & + "the model offline. This can require a large amount of memory "// & + "and will make initialization very slow. However, for offline "// & "runs spanning more than a year this can reduce total I/O overhead", & default = .false.) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index a3c75bd7fd..d3e6abd00d 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -202,9 +202,8 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) call get_param(param_file, mdl, "USE_OCMIP2_CFC", CS%use_OCMIP2_CFC, & "If true, use the MOM_OCMIP2_CFC tracer package.", & default=.false.) - call get_param(param_file, mdl, "USE_generic_tracer", & - CS%use_MOM_generic_tracer, & - "If true and _USE_GENERIC_TRACER is defined as a \n"//& + call get_param(param_file, mdl, "USE_generic_tracer", CS%use_MOM_generic_tracer, & + "If true and _USE_GENERIC_TRACER is defined as a "//& "preprocessor macro, use the MOM_generic_tracer packages.", & default=.false.) call get_param(param_file, mdl, "USE_PSEUDO_SALT_TRACER", CS%use_pseudo_salt_tracer, & diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 48ec698696..261d8d1315 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1403,8 +1403,8 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) "The background along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", CS%KhTr_Slope_Cff, & - "The scaling coefficient for along-isopycnal tracer \n"//& - "diffusivity using a shear-based (Visbeck-like) \n"//& + "The scaling coefficient for along-isopycnal tracer "//& + "diffusivity using a shear-based (Visbeck-like) "//& "parameterization. A non-zero value enables this param.", & units="nondim", default=0.0) call get_param(param_file, mdl, "KHTR_MIN", CS%KhTr_Min, & @@ -1414,34 +1414,34 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) "The maximum along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0) call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", CS%KhTr_passivity_coeff, & - "The coefficient that scales deformation radius over \n"//& - "grid-spacing in passivity, where passiviity is the ratio \n"//& - "between along isopycnal mxiing of tracers to thickness mixing. \n"//& + "The coefficient that scales deformation radius over "//& + "grid-spacing in passivity, where passivity is the ratio "//& + "between along isopycnal mixing of tracers to thickness mixing. "//& "A non-zero value enables this parameterization.", & units="nondim", default=0.0) call get_param(param_file, mdl, "KHTR_PASSIVITY_MIN", CS%KhTr_passivity_min, & - "The minimum passivity which is the ratio between \n"//& - "along isopycnal mxiing of tracers to thickness mixing. \n", & + "The minimum passivity which is the ratio between "//& + "along isopycnal mixing of tracers to thickness mixing.", & units="nondim", default=0.5) call get_param(param_file, mdl, "DIFFUSE_ML_TO_INTERIOR", CS%Diffuse_ML_interior, & - "If true, enable epipycnal mixing between the surface \n"//& + "If true, enable epipycnal mixing between the surface "//& "boundary layer and the interior.", default=.false.) call get_param(param_file, mdl, "CHECK_DIFFUSIVE_CFL", CS%check_diffusive_CFL, & - "If true, use enough iterations the diffusion to ensure \n"//& - "that the diffusive equivalent of the CFL limit is not \n"//& - "violated. If false, always use the greater of 1 or \n"//& + "If true, use enough iterations the diffusion to ensure "//& + "that the diffusive equivalent of the CFL limit is not "//& + "violated. If false, always use the greater of 1 or "//& "MAX_TR_DIFFUSION_CFL iteration.", default=.false.) call get_param(param_file, mdl, "MAX_TR_DIFFUSION_CFL", CS%max_diff_CFL, & - "If positive, locally limit the along-isopycnal tracer \n"//& - "diffusivity to keep the diffusive CFL locally at or \n"//& - "below this value. The number of diffusive iterations \n"//& + "If positive, locally limit the along-isopycnal tracer "//& + "diffusivity to keep the diffusive CFL locally at or "//& + "below this value. The number of diffusive iterations "//& "is often this value or the next greater integer.", & units="nondim", default=-1.0) CS%ML_KhTR_scale = 1.0 if (CS%Diffuse_ML_interior) then call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & - "With Diffuse_ML_interior, the ratio of the truly \n"//& - "horizontal diffusivity in the mixed layer to the \n"//& + "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.", & units="nondim", default=1.0) endif diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 34f788c952..ee7340020c 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -99,16 +99,16 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ADVECTION_TEST_X_ORIGIN", CS%x_origin, & - "The x-coorindate of the center of the test-functions.\n", default=0.) + "The x-coorindate of the center of the test-functions.", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_ORIGIN", CS%y_origin, & - "The y-coorindate of the center of the test-functions.\n", default=0.) + "The y-coorindate of the center of the test-functions.", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_X_WIDTH", CS%x_width, & - "The x-width of the test-functions.\n", default=0.) + "The x-width of the test-functions.", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_WIDTH", CS%y_width, & - "The y-width of the test-functions.\n", default=0.) + "The y-width of the test-functions.", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_TRACER_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then @@ -118,14 +118,14 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ CS%tracer_IC_file) endif call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if the tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& "restart files of a restarted run.", default=.false.) diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index fa95d8aa77..d007e18a16 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -99,14 +99,14 @@ function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restar ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "IMPULSE_SOURCE_TIME", CS%remaining_source_time, & - "Length of time for the boundary tracer to be injected\n"//& - "into the mixed layer. After this time has elapsed, the\n"//& + "Length of time for the boundary tracer to be injected "//& + "into the mixed layer. After this time has elapsed, the "//& "surface becomes a sink for the boundary impulse tracer.", & default=31536000.0) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if the tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& "restart files of a restarted run.", default=.false.) CS%ntr = NTR_MAX allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 51b5ab6c08..285b9e2b41 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -99,7 +99,7 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & - "The number of dye tracers in this run. Each tracer \n"//& + "The number of dye tracers in this run. Each tracer "//& "should have a separate region.", default=0) allocate(CS%dye_source_minlon(CS%ntr), & CS%dye_source_maxlon(CS%ntr), & @@ -140,7 +140,7 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) CS%dye_source_mindepth(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MINDEPTH", CS%dye_source_mindepth, & - "This is the minumum depth at which we inject dyes.", & + "This is the minimum depth at which we inject dyes.", & units="m", scale=US%m_to_Z, fail_if_missing=.true.) if (minval(CS%dye_source_mindepth(:)) < -1.e29*US%m_to_Z) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MINDEPTH") diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 7abbafa5fc..f2828bddc4 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -83,14 +83,14 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & - "The number of dye tracers in this run. Each tracer \n"//& + "The number of dye tracers in this run. Each tracer "//& "should have a separate boundary segment.", default=0) allocate(CS%ind_tr(CS%ntr)) allocate(CS%tr_desc(CS%ntr)) call get_param(param_file, mdl, "dyed_obc_TRACER_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the dyed_obc tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the dyed_obc tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 562947a011..60463f9f1c 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -102,23 +102,23 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DO_IDEAL_AGE", do_ideal_age, & - "If true, use an ideal age tracer that is set to 0 age \n"//& + "If true, use an ideal age tracer that is set to 0 age "//& "in the mixed layer and ages at unit rate in the interior.", & default=.true.) call get_param(param_file, mdl, "DO_IDEAL_VINTAGE", do_vintage, & - "If true, use an ideal vintage tracer that is set to an \n"//& - "exponentially increasing value in the mixed layer and \n"//& + "If true, use an ideal vintage tracer that is set to an "//& + "exponentially increasing value in the mixed layer and "//& "is conserved thereafter.", default=.false.) call get_param(param_file, mdl, "DO_IDEAL_AGE_DATED", do_ideal_age_dated, & - "If true, use an ideal age tracer that is everywhere 0 \n"//& - "before IDEAL_AGE_DATED_START_YEAR, but the behaves like \n"//& - "the standard ideal age tracer - i.e. is set to 0 age in \n"//& + "If true, use an ideal age tracer that is everywhere 0 "//& + "before IDEAL_AGE_DATED_START_YEAR, but the behaves like "//& + "the standard ideal age tracer - i.e. is set to 0 age in "//& "the mixed layer and ages at unit rate in the interior.", & default=.false.) call get_param(param_file, mdl, "AGE_IC_FILE", CS%IC_file, & - "The file in which the age-tracer initial values can be \n"//& + "The file in which the age-tracer initial values can be "//& "found, or an empty string for internal initialization.", & default=" ") if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then @@ -131,9 +131,9 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "If true, AGE_IC_FILE is in depth space, not layer space", & default=.false.) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if the tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& "restart files of a restarted run.", default=.false.) CS%ntr = 0 diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 6156c20e24..f498ac4717 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -110,7 +110,7 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "OIL_IC_FILE", CS%IC_file, & - "The file in which the oil tracer initial values can be \n"//& + "The file in which the oil tracer initial values can be "//& "found, or an empty string for internal initialization.", & default=" ") if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then @@ -124,9 +124,9 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) default=.false.) call get_param(param_file, mdl, "OIL_MAY_REINIT", CS%oil_may_reinit, & - "If true, oil tracers may go through the initialization \n"//& - "code if they are not found in the restart files. \n"//& - "Otherwise it is a fatal error if the oil tracers are not \n"//& + "If true, oil tracers may go through the initialization "//& + "code if they are not found in the restart files. "//& + "Otherwise it is a fatal error if the oil tracers are not "//& "found in the restart files of a restarted run.", & default=.false.) call get_param(param_file, mdl, "OIL_SOURCE_LONGITUDE", CS%oil_source_longitude, & @@ -136,14 +136,14 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "The geographic latitude of the oil source.", units="degrees N", & fail_if_missing=.true.) call get_param(param_file, mdl, "OIL_SOURCE_LAYER", CS%oil_source_k, & - "The layer into which the oil is introduced, or a \n"//& - "negative number for a vertically uniform source, \n"//& + "The layer into which the oil is introduced, or a "//& + "negative number for a vertically uniform source, "//& "or 0 not to use this tracer.", units="Layer", default=0) call get_param(param_file, mdl, "OIL_SOURCE_RATE", CS%oil_source_rate, & "The rate of oil injection.", units="kg s-1", default=1.0) call get_param(param_file, mdl, "OIL_DECAY_DAYS", CS%oil_decay_days, & - "The decay timescale in days (if positive), or no decay \n"//& - "if 0, or use the temperature dependent decay rate of \n"//& + "The decay timescale in days (if positive), or no decay "//& + "if 0, or use the temperature dependent decay rate of "//& "Adcroft et al. (GRL, 2010) if negative.", units="days", & default=0.0) call get_param(param_file, mdl, "OIL_DATED_START_YEAR", CS%oil_start_year, & diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 26ea3fb957..395857e0a1 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -87,8 +87,8 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "TRACER_EXAMPLE_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the DOME tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the DOME tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -97,8 +97,8 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS CS%tracer_IC_file) endif call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 3d54df5955..65cf4bc90a 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -192,16 +192,16 @@ subroutine BFB_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "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) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, "LFR_SLAT", CS%lfrslat, & @@ -224,13 +224,13 @@ subroutine BFB_surface_forcing_init(Time, G, param_file, diag, CS) default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "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 \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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. diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index b81061ab29..a9a5be3d42 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -385,19 +385,19 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed call get_param(param_file, mdl, "DOME2D_WEST_SPONGE_TIME_SCALE", dome2d_west_sponge_time_scale, & - 'The time-scale on the west edge of the domain for restoring T/S\n' //& + 'The time-scale on the west edge of the domain for restoring T/S '//& 'in the sponge. If zero, the western sponge is disabled', & units='s', default=0.) call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_TIME_SCALE", dome2d_east_sponge_time_scale, & - 'The time-scale on the east edge of the domain for restoring T/S\n' //& + 'The time-scale on the east edge of the domain for restoring T/S '//& 'in the sponge. If zero, the eastern sponge is disabled', & units='s', default=0.) call get_param(param_file, mdl, "DOME2D_WEST_SPONGE_WIDTH", dome2d_west_sponge_width, & - 'The fraction of the domain in which the western sponge for restoring T/S\n' //& + 'The fraction of the domain in which the western sponge for restoring T/S '//& 'is active.', & units='nondim', default=0.1) call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_WIDTH", dome2d_east_sponge_width, & - 'The fraction of the domain in which the eastern sponge for restoring T/S\n' //& + 'The fraction of the domain in which the eastern sponge for restoring T/S '//& 'is active.', & units='nondim', default=0.1) diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 39c9321111..cce8b43a71 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -321,7 +321,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, case ( REGRIDDING_LAYER ) call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & - "If true, accept the prescribed temperature and fit the \n"//& + "If true, accept the prescribed temperature and fit the "//& "salinity; otherwise take salinity and fit temperature.", & default=.false., do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DS", drho_dS1, & @@ -628,16 +628,16 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! sponge, FIT_SALINITY=False. The oposite is true for temp. One can ! combined the *correct* temp and salt values in one file instead. call get_param(PF, mdl, "ISOMIP_SPONGE_FILE", state_file, & - "The name of the file with temps., salts. and interfaces to \n"// & + "The name of the file with temps., salts. and interfaces to "//& "damp toward.", fail_if_missing=.true.) call get_param(PF, mdl, "SPONGE_PTEMP_VAR", temp_var, & - "The name of the potential temperature variable in \n"//& + "The name of the potential temperature variable in "//& "SPONGE_STATE_FILE.", default="Temp") call get_param(PF, mdl, "SPONGE_SALT_VAR", salt_var, & - "The name of the salinity variable in \n"//& + "The name of the salinity variable in "//& "SPONGE_STATE_FILE.", default="Salt") call get_param(PF, mdl, "SPONGE_ETA_VAR", eta_var, & - "The name of the interface height variable in \n"//& + "The name of the interface height variable in "//& "SPONGE_STATE_FILE.", default="eta") !read temp and eta diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index c29e3beded..73d4a2ea1f 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -34,7 +34,7 @@ module Idealized_hurricane #include -public idealized_hurricane_wind_init !Public interface to intialize the idealized +public idealized_hurricane_wind_init !Public interface to initialize the idealized ! hurricane wind profile. public idealized_hurricane_wind_forcing !Public interface to update the idealized ! hurricane wind profile. @@ -121,25 +121,25 @@ subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) ! Parameters for computing a wind profile call get_param(param_file, mdl, "IDL_HURR_RHO_AIR", CS%rho_a, & - "Air density used to compute the idealized hurricane"// & + "Air density used to compute the idealized hurricane "//& "wind profile.", units='kg/m3', default=1.2) call get_param(param_file, mdl, "IDL_HURR_AMBIENT_PRESSURE", & - CS%pressure_ambient, "Ambient pressure used in the "// & + CS%pressure_ambient, "Ambient pressure used in the "//& "idealized hurricane wind profile.", units='Pa', & default=101200.) call get_param(param_file, mdl, "IDL_HURR_CENTRAL_PRESSURE", & - CS%pressure_central, "Central pressure used in the "// & + CS%pressure_central, "Central pressure used in the "//& "idealized hurricane wind profile.", units='Pa', & default=96800.) call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & - CS%rad_max_wind, "Radius of maximum winds used in the"// & + CS%rad_max_wind, "Radius of maximum winds used in the "//& "idealized hurricane wind profile.", units='m', & default=50.e3) call get_param(param_file, mdl, "IDL_HURR_MAX_WIND", CS%max_windspeed, & "Maximum wind speed used in the idealized hurricane"// & "wind profile.", units='m/s', default=65.) call get_param(param_file, mdl, "IDL_HURR_TRAN_SPEED", CS%hurr_translation_spd, & - "Translation speed of hurricane used in the idealized"// & + "Translation speed of hurricane used in the idealized "//& "hurricane wind profile.", units='m/s', default=5.0) call get_param(param_file, mdl, "IDL_HURR_TRAN_DIR", CS%hurr_translation_dir, & "Translation direction (towards) of hurricane used in the "//& @@ -153,7 +153,7 @@ subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) "Idealized Hurricane initial Y position", & units='m', default=0.) call get_param(param_file, mdl, "IDL_HURR_TAU_CURR_REL", CS%relative_tau, & - "Current relative stress switch"// & + "Current relative stress switch "//& "used in the idealized hurricane wind profile.", & units='', default=.false.) @@ -163,20 +163,20 @@ subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) "invoking a modification (bug) in the wind profile meant to "//& "reproduce a previous implementation.", units='', default=.false.) call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_MODE, & - "Single Column mode switch"// & + "Single Column mode switch "//& "used in the SCM idealized hurricane wind profile.", & units='', default=.false.) call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%DY_from_center, & - "Y distance of station used in the SCM idealized hurricane "// & + "Y distance of station used in the SCM idealized hurricane "//& "wind profile.", units='m', default=50.e3) ! The following parameters are model run-time parameters which are used ! and logged elsewhere and so should not be logged here. The default ! value should be consistent with the rest of the model. call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, do_not_log=.true.) call get_param(param_file, mdl, "GUST_CONST", CS%gustiness, & @@ -258,8 +258,7 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) Uocn = state%u(I,j)*REL_TAU_FAC Vocn = 0.25*(state%v(i,J)+state%v(i+1,J-1)& +state%v(i+1,J)+state%v(i,J-1))*REL_TAU_FAC - f = abs(0.5*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac & - + fbench + f = abs(0.5*US%s_to_T*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then YY = YC + CS%dy_from_center @@ -281,8 +280,7 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) Uocn = 0.25*(state%u(I,j)+state%u(I-1,j+1)& +state%u(I-1,j)+state%u(I,j+1))*REL_TAU_FAC Vocn = state%v(i,J)*REL_TAU_FAC - f = abs(0.5*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac & - + fbench + f = abs(0.5*US%s_to_T*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then YY = YC + CS%dy_from_center @@ -487,10 +485,10 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) B = C**2 * 1.2 * exp(1.0) endif A = (CS%rad_max_wind/1000.)**B - f =G%CoriolisBu(is,js) ! f=f(x,y) but in the SCM is constant + f = US%s_to_T*G%CoriolisBu(is,js) ! f=f(x,y) but in the SCM is constant if (BR_Bench) then ! f reset to value used in generated wind for benchmark test - f = 5.5659e-05 + f = 5.5659e-05 !### A constant value in s-1. endif !/ BR ! Calculate x position as a function of time. diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 85e11435dc..7df6390c10 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -75,11 +75,11 @@ function register_Kelvin_OBC(param_file, CS, OBC_Reg) call get_param(param_file, mdl, "TOPO_CONFIG", config, do_not_log=.true.) if (trim(config) == "Kelvin") then call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", CS%coast_offset1, & - "The distance along the southern and northern boundaries \n"//& + "The distance along the southern and northern boundaries "//& "at which the coasts angle in.", & units="km", default=100.0) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", CS%coast_offset2, & - "The distance from the southern and northern boundaries \n"//& + "The distance from the southern and northern boundaries "//& "at which the coasts angle in.", & units="km", default=10.0) call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", CS%coast_angle, & @@ -297,7 +297,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) - val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) + val2 = fac * exp(- 0.5 * US%s_to_T * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = val1 * cff * sina / & (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j))) * val2 diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index a061fcb3eb..3ba4f0c376 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -509,11 +509,11 @@ subroutine controlled_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call log_param(param_file, mdl, "CTRL_FORCE_INTEGRATED", do_integrated, & - "If true, use a PI controller to determine the surface \n"//& + "If true, use a PI controller to determine the surface "//& "forcing that is consistent with the observed mean properties.", & default=.false.) call log_param(param_file, mdl, "CTRL_FORCE_NUM_CYCLE", num_cycle, & - "The number of cycles per year in the controlled forcing, \n"//& + "The number of cycles per year in the controlled forcing, "//& "or 0 for no cyclic forcing.", default=0) if (.not.associated(CS)) return @@ -521,33 +521,33 @@ subroutine controlled_forcing_init(Time, G, param_file, diag, CS) CS%diag => diag call get_param(param_file, mdl, "CTRL_FORCE_HEAT_INT_RATE", CS%heat_int_rate, & - "The integrated rate at which heat flux anomalies are \n"//& + "The integrated rate at which heat flux anomalies are "//& "accumulated.", units="s-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_PREC_INT_RATE", CS%prec_int_rate, & - "The integrated rate at which precipitation anomalies \n"//& + "The integrated rate at which precipitation anomalies "//& "are accumulated.", units="s-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_HEAT_CYC_RATE", CS%heat_cyc_rate, & - "The integrated rate at which cyclical heat flux \n"//& + "The integrated rate at which cyclical heat flux "//& "anomalies are accumulated.", units="s-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_PREC_CYC_RATE", CS%prec_cyc_rate, & - "The integrated rate at which cyclical precipitation \n"//& + "The integrated rate at which cyclical precipitation "//& "anomalies are accumulated.", units="s-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_SMOOTH_LENGTH", smooth_len, & - "The length scales over which controlled forcing \n"//& + "The length scales over which controlled forcing "//& "anomalies are smoothed.", units="m", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_HEAT", CS%lam_heat, & - "A constant of proportionality between SST anomalies \n"//& + "A constant of proportionality between SST anomalies "//& "and controlling heat fluxes", "W m-2 K-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_PREC", CS%lam_prec, & - "A constant of proportionality between SSS anomalies \n"//& + "A constant of proportionality between SSS anomalies "//& "(normalised by mean SSS) and controlling precipitation.", & "kg m-2", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_CYC_HEAT", CS%lam_cyc_heat, & - "A constant of proportionality between SST anomalies \n"//& + "A constant of proportionality between SST anomalies "//& "and cyclical controlling heat fluxes", "W m-2 K-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_CYC_PREC", CS%lam_cyc_prec, & - "A constant of proportionality between SSS anomalies \n"//& - "(normalised by mean SSS) and cyclical controlling \n"//& + "A constant of proportionality between SSS anomalies "//& + "(normalised by mean SSS) and cyclical controlling "//& "precipitation.", "kg m-2", default=0.0) CS%Len2 = smooth_len**2 diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index fedd46ab03..3bfab9e4fc 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -111,11 +111,11 @@ module MOM_wave_interface type(diag_ctrl), pointer, public :: diag !< A structure that is used to regulate the !! timing of diagnostic output. - ! An arbitrary lower-bound on the Langmuir number. Run-time parameter. - ! Langmuir number is sqrt(u_star/u_stokes). When both are small - ! but u_star is orders of magnitude smaller the Langmuir number could - ! have unintended consequences. Since both are small it can be safely capped - ! to avoid such consequences. + !> An arbitrary lower-bound on the Langmuir number. Run-time parameter. + !! Langmuir number is sqrt(u_star/u_stokes). When both are small + !! but u_star is orders of magnitude smaller the Langmuir number could + !! have unintended consequences. Since both are small it can be safely capped + !! to avoid such consequences. real :: La_min = 0.05 !>@{ Diagnostic handles @@ -302,9 +302,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) case (INPUT_STRING)! A method to input the Stokes band (globally uniform) DataSource = Input call get_param(param_file,mdl,"SURFBAND_NB",NumBands, & - "Prescribe number of wavenumber bands for Stokes drift. \n"// & - " Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and \n"// & - " STOKES_Y, there are no safety checks in the code.", & + "Prescribe number of wavenumber bands for Stokes drift. "// & + "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "// & + "STOKES_Y, there are no safety checks in the code.", & units='', default=1) allocate( CS%WaveNum_Cen(1:NumBands) ) CS%WaveNum_Cen(:) = 0.0 @@ -351,16 +351,16 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in \n"//& - " Lanmguir number calculation, where La = sqrt(ust/Stokes).", & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & units="nondim",default=0.04) call get_param(param_file, mdl, "LA_MISALIGNMENT", LA_Misalignment, & "Flag (logical) if using misalignment bt shear and waves in LA",& default=.false.) call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & - "A minimum value for all Langmuir numbers that is not physical, \n"//& - " but is likely only encountered when the wind is very small and \n"//& - " therefore its effects should be mostly benign.",units="nondim",& + "A minimum value for all Langmuir numbers that is not physical, "//& + "but is likely only encountered when the wind is very small and "//& + "therefore its effects should be mostly benign.",units="nondim",& default=0.05) ! Allocate and initialize @@ -407,8 +407,8 @@ subroutine MOM_wave_interface_init_lite(param_file) ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in \n"//& - " Lanmguir number calculation, where La = sqrt(ust/Stokes).", & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & units="nondim",default=0.04) if (WaveMethod==NULL_WaveMethod) then @@ -1251,7 +1251,7 @@ end subroutine StokesMixing !! CHECK THAT RIGHT TIMESTEP IS PASSED IF YOU USE THIS** !! !! Not accessed in the standard code. -subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES) +subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) type(ocean_grid_type), & intent(in) :: G !< Ocean grid type(verticalGrid_type), & @@ -1265,8 +1265,9 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES) intent(inout) :: v !< Velocity j-component [m s-1] type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: DVel + real :: DVel ! A rescaled velocity change [m s-1 T-1 ~> m s-2] integer :: i,j,k do k = 1, G%ke @@ -1274,7 +1275,7 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES) do I = G%iscB, G%iecB DVel = 0.25*(WAVES%us_y(i,j+1,k)+WAVES%us_y(i-1,j+1,k))*G%CoriolisBu(i,j+1) + & 0.25*(WAVES%us_y(i,j,k)+WAVES%us_y(i-1,j,k))*G%CoriolisBu(i,j) - u(I,j,k) = u(I,j,k) + DVEL*DT + u(I,j,k) = u(I,j,k) + DVEL*US%s_to_T*DT enddo enddo enddo @@ -1284,7 +1285,7 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES) do i = G%isc, G%iec DVel = 0.25*(WAVES%us_x(i+1,j,k)+WAVES%us_x(i+1,j-1,k))*G%CoriolisBu(i+1,j) + & 0.25*(WAVES%us_x(i,j,k)+WAVES%us_x(i,j-1,k))*G%CoriolisBu(i,j) - v(i,J,k) = v(i,j,k) - DVEL*DT + v(i,J,k) = v(i,j,k) - DVEL*US%s_to_T*DT enddo enddo enddo diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 357396b794..ab964b5269 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -67,14 +67,13 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par if (.not.just_read) call log_version(param_file, mdl, version) call get_param(param_file, mdl, "HALF_STRAT_DEPTH", half_strat, & -!### UNCOMMENT TO FIX THIS "The fractional depth where the stratification is centered.", & - "The maximum depth of the ocean.", & + "The fractional depth where the stratification is centered.", & units="nondim", default = 0.5, do_not_log=just_read) call get_param(param_file, mdl, "JET_WIDTH", jet_width, & "The width of the zonal-mean jet.", units="km", & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & - "The interface height scale associated with the \n"//& + "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.not.just_read, do_not_log=just_read) @@ -148,7 +147,7 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p "The width of the zonal-mean jet.", units="km", & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & - "The interface height scale associated with the \n"//& + "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.not.just_read, do_not_log=just_read) @@ -165,11 +164,11 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p ! This uses d/d y_2 atan(y_2 / jet_width) ! u(I,j,k) = u(I,j,k+1) + (1e-3 * jet_height / & ! (jet_width * (1.0 + (y_2 / jet_width)**2))) * & -! (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) +! (2.0 * GV%g_prime(K+1) * US%T_to_s / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) ! This uses d/d y_2 tanh(y_2 / jet_width) u(I,j,k) = u(I,j,k+1) + (1e-3 * (jet_height / jet_width) * & (sech(y_2 / jet_width))**2 ) * & - (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) + (2.0 * GV%g_prime(K+1) * US%T_to_s / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) enddo ; enddo ; enddo do k=1,nz ; do j=js,je ; do I=is-1,ie @@ -249,7 +248,7 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) "The width of the zonal-mean jet.", units="km", & fail_if_missing=.true.) call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & - "The interface height scale associated with the \n"//& + "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.true.) diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index a3f23361f7..a32a2978b7 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -7,6 +7,7 @@ module Rossby_front_2d_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type @@ -159,9 +160,10 @@ end subroutine Rossby_front_initialize_temperature_salinity !> Initialization of u and v in the Rossby front test -subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, param_file, just_read_params) +subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(out) :: u !< i-component of velocity [m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & @@ -178,7 +180,8 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, param_file, just_rea real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f real :: dRho_dT real :: Dml, zi, zc, zm ! Depths [Z ~> m]. - real :: f, Ty + real :: f ! The local Coriolis parameter [T-1 ~> s-1] + real :: Ty real :: hAtU ! Interpolated layer thickness [Z ~> m]. integer :: i, j, k, is, ie, js, je, nz logical :: just_read ! If true, just read parameters but set nothing. @@ -200,9 +203,9 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, param_file, just_rea u(:,:,:) = 0.0 do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 - f = 0.5*( G%CoriolisBu(I,j) + G%CoriolisBu(I,j-1) ) + f = 0.5* (G%CoriolisBu(I,j) + G%CoriolisBu(I,j-1) ) dUdT = 0.0 ; if (abs(f) > 0.0) & - dUdT = ( GV%g_Earth * dRho_dT ) / ( f * GV%Rho0 ) + dUdT = ( GV%g_Earth * dRho_dT ) / ( US%s_to_T * f * GV%Rho0 ) Dml = Hml( G, G%geoLatT(i,j) ) Ty = dTdy( G, T_range, G%geoLatT(i,j) ) zi = 0. diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 4372586820..eb7f765890 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -60,15 +60,15 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_para if (.not.just_read) call log_version(param_file, mdl, version, "") ! Parameters read by cartesian grid initialization call get_param(param_file, mdl, "DISK_RADIUS", diskrad, & - "The radius of the initially elevated disk in the \n"//& + "The radius of the initially elevated disk in the "//& "circle_obcs test case.", units=G%x_axis_units, & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "DISK_X_OFFSET", xOffset, & - "The x-offset of the initially elevated disk in the \n"//& + "The x-offset of the initially elevated disk in the "//& "circle_obcs test case.", units=G%x_axis_units, & default = 0.0, do_not_log=just_read) call get_param(param_file, mdl, "DISK_IC_AMPLITUDE", IC_amp, & - "Initial amplitude of interface height displacements \n"//& + "Initial amplitude of interface height displacements "//& "in the circle_obcs test case.", & units='m', default=5.0, scale=GV%m_to_H, do_not_log=just_read) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index c6e6354ef3..b16b3a341c 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -132,7 +132,7 @@ subroutine dumbbell_initialize_thickness ( h, G, GV, US, param_file, just_read_p call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & - "The granularity of initial interface height values \n"//& + "The granularity of initial interface height values "//& "per meter, to avoid sensivity to order-of-arithmetic changes.", & default=2048.0, units="m-1", scale=US%Z_to_m, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -220,7 +220,7 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_DENSITY_PROFILE", density_profile, & - 'Initial profile shape. Valid values are "linear", "parabolic"\n'// & + 'Initial profile shape. Valid values are "linear", "parabolic" '// & 'and "exponential".', default='linear', do_not_log=just_read) call get_param(param_file, mdl,"DUMBBELL_SREF", S_surf, & 'DUMBBELL REFERENCE SALINITY', units='1e-3', default=34., do_not_log=just_read) diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 7a2360fc7a..6d3e46bd73 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -203,16 +203,16 @@ subroutine dumbbell_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "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) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "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, "DUMBBELL_SLP_AMP", CS%slp_amplitude, & @@ -231,13 +231,13 @@ subroutine dumbbell_surface_forcing_init(Time, G, param_file, diag, CS) default=2., do_not_log=.true.) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "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 \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "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. diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index cb1b9a6b2f..61f8183275 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -101,7 +101,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) 'dyed_channel_set_OBC_data() was called but OBC type was not initialized!') call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & - "The number of dye tracers in this run. Each tracer \n"//& + "The number of dye tracers in this run. Each tracer "//& "should have a separate boundary segment.", default=0, & do_not_log=.true.) diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index eed0f804b4..39519ce8a6 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -52,7 +52,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) if (.not.associated(OBC)) return call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & - "The number of dye tracers in this run. Each tracer \n"//& + "The number of dye tracers in this run. Each tracer "//& "should have a separate boundary segment.", default=0, & do_not_log=.true.) diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index c442f63891..1a3e8dd308 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -56,12 +56,12 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "FRONT_DISPLACEMENT", front_displacement, & - "The vertical displacement of interfaces across the front. \n"//& + "The vertical displacement of interfaces across the front. "//& "A value larger in magnitude that MAX_DEPTH is truncated,", & units="m", fail_if_missing=.not.just_read, do_not_log=just_read, scale=US%m_to_Z) call get_param(param_file, mdl, "THERMOCLINE_THICKNESS", thermocline_thickness, & - "The thickness of the thermocline in the lock exchange \n"//& - "experiment. A value of zero creates a two layer system \n"//& + "The thickness of the thermocline in the lock exchange "//& + "experiment. A value of zero creates a two layer system "//& "with vanished layers in between the two inflated layers.", & default=0., units="m", do_not_log=just_read, scale=US%m_to_Z) diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 6180ff2e00..0df24efb42 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -53,11 +53,11 @@ subroutine seamount_initialize_topography( D, G, param_file, max_depth ) "Non-dimensional height of seamount.", & units="non-dim", default=0.5) call get_param(param_file, mdl,"SEAMOUNT_X_LENGTH_SCALE",Lx, & - "Length scale of seamount in x-direction.\n"//& + "Length scale of seamount in x-direction. "//& "Set to zero make topography uniform in the x-direction.", & units="Same as x,y", default=20.) call get_param(param_file, mdl,"SEAMOUNT_Y_LENGTH_SCALE",Ly, & - "Length scale of seamount in y-direction.\n"//& + "Length scale of seamount in y-direction. "//& "Set to zero make topography uniform in the y-direction.", & units="Same as x,y", default=0.) @@ -132,7 +132,7 @@ subroutine seamount_initialize_thickness ( h, G, GV, US, param_file, just_read_p call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & - "The granularity of initial interface height values \n"//& + "The granularity of initial interface height values "//& "per meter, to avoid sensivity to order-of-arithmetic changes.", & default=2048.0, units="m-1", scale=US%Z_to_m, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -217,7 +217,7 @@ subroutine seamount_initialize_temperature_salinity ( T, S, h, G, GV, param_file call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_DENSITY_PROFILE", density_profile, & - 'Initial profile shape. Valid values are "linear", "parabolic"\n'// & + 'Initial profile shape. Valid values are "linear", "parabolic" '//& 'and "exponential".', default='linear', do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & 'Initial surface salinity', units='1e-3', default=34., do_not_log=just_read) diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 1a52519122..cd80514bea 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -69,7 +69,7 @@ function register_shelfwave_OBC(param_file, CS, OBC_Reg) "Length scale of shelfwave in x-direction.",& units="Same as x,y", default=100.) call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE",CS%Ly, & - "Length scale of exponential dropoff of topography\n"//& + "Length scale of exponential dropoff of topography "//& "in the y-direction.", & units="Same as x,y", default=50.) call get_param(param_file, mdl,"SHELFWAVE_Y_MODE",CS%jj, & diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 990d43fda4..e099d808d5 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -84,7 +84,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, US, param_file, just_read_p just_read = .false. ; if (present(just_read_params)) just_read = just_read_params if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SLOSHING_IC_AMPLITUDE", a0, & - "Initial amplitude of sloshing internal interface height \n"//& + "Initial amplitude of sloshing internal interface height "//& "displacements it the sloshing test case.", & units='m', default=75.0, scale=US%m_to_Z, do_not_log=just_read) call get_param(param_file, mdl, "SLOSHING_IC_BUG", use_IC_bug, & diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 5a29614506..10d04af0c3 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -26,7 +26,7 @@ module user_change_diffusivity !> Control structure for user_change_diffusivity type, public :: user_change_diff_CS ; private real :: Kd_add !< The scale of a diffusivity that is added everywhere - !! without any filtering or scaling [Z2 s-1 ~> m2 s-1]. + !! without any filtering or scaling [Z2 T-1 ~> m2 s-1]. real :: lat_range(4) !< 4 values that define the latitude range over which !! a diffusivity scaled by Kd_add is added [degLat]. real :: rho_range(4) !< 4 values that define the coordinate potential @@ -53,16 +53,16 @@ subroutine user_change_diff(h, tv, G, GV, CS, Kd_lay, Kd_int, T_f, S_f, Kd_int_a !! fields. Absent fields have NULL ptrs. type(user_change_diff_CS), pointer :: CS !< This module's control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of - !! each layer [Z2 s-1 ~> m2 s-1]. + !! each layer [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity - !! at each interface [Z2 s-1 ~> m2 s-1]. + !! at each interface [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: T_f !< Temperature with massless !! layers filled in vertically [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: S_f !< Salinity with massless !! layers filled in vertically [ppt]. real, dimension(:,:,:), optional, pointer :: Kd_int_add !< The diapycnal !! diffusivity that is being added at - !! each interface [Z2 s-1 ~> m2 s-1]. + !! each interface [Z2 T-1 ~> m2 s-1]. ! Local variables real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density in layers [kg m-3]. real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures. @@ -221,25 +221,26 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USER_KD_ADD", CS%Kd_add, & - "A user-specified additional diffusivity over a range of \n"//& - "latitude and density.", default=0.0, units="m2 s-1", scale=US%m_to_Z**2) + "A user-specified additional diffusivity over a range of "//& + "latitude and density.", default=0.0, units="m2 s-1", & + scale=US%m2_s_to_Z2_T) if (CS%Kd_add /= 0.0) then call get_param(param_file, mdl, "USER_KD_ADD_LAT_RANGE", CS%lat_range(:), & - "Four successive values that define a range of latitudes \n"//& - "over which the user-specified extra diffusivity is \n"//& - "applied. The four values specify the latitudes at \n"//& - "which the extra diffusivity starts to increase from 0, \n"//& - "hits its full value, starts to decrease again, and is \n"//& + "Four successive values that define a range of latitudes "//& + "over which the user-specified extra diffusivity is "//& + "applied. The four values specify the latitudes at "//& + "which the extra diffusivity starts to increase from 0, "//& + "hits its full value, starts to decrease again, and is "//& "back to 0.", units="degree", default=-1.0e9) call get_param(param_file, mdl, "USER_KD_ADD_RHO_RANGE", CS%rho_range(:), & - "Four successive values that define a range of potential \n"//& - "densities over which the user-given extra diffusivity \n"//& - "is applied. The four values specify the density at \n"//& - "which the extra diffusivity starts to increase from 0, \n"//& - "hits its full value, starts to decrease again, and is \n"//& + "Four successive values that define a range of potential "//& + "densities over which the user-given extra diffusivity "//& + "is applied. The four values specify the density at "//& + "which the extra diffusivity starts to increase from 0, "//& + "hits its full value, starts to decrease again, and is "//& "back to 0.", units="kg m-3", default=-1.0e9) call get_param(param_file, mdl, "USER_KD_ADD_USE_ABS_LAT", CS%use_abs_lat, & - "If true, use the absolute value of latitude when \n"//& + "If true, use the absolute value of latitude when "//& "checking whether a point fits into range of latitudes.", & default=.false.) endif diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 1de9c3664a..d79e9183bf 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -246,7 +246,7 @@ end subroutine write_user_log !! - v - Meridional velocity [m s-1]. !! - h - Layer thickness [H ~> m or kg m-2]. (Must be positive.) !! - G%bathyT - Basin depth [Z ~> m]. (Must be positive.) -!! - G%CoriolisBu - The Coriolis parameter [s-1]. +!! - G%CoriolisBu - The Coriolis parameter [T-1 ~> s-1]. !! - GV%g_prime - The reduced gravity at each interface [m2 Z-1 s-2 ~> m s-2]. !! - GV%Rlay - Layer potential density (coordinate variable) [kg m-3]. !! If ENABLE_THERMODYNAMICS is defined: