diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 02c6d15877..1622ae9886 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -116,7 +116,7 @@ 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 '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all -B') > job.sh + - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all') > 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 diff --git a/.gitmodules b/.gitmodules index b499e43096..637f1188ed 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,3 @@ [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran url = https://github.com/TEOS-10/GSW-Fortran.git -[submodule "pkg/MOM6_DA_hooks"] - path = pkg/MOM6_DA_hooks - url = https://github.com/MJHarrison-GFDL/MOM6_DA_hooks.git -[submodule "pkg/geoKdTree"] - path = pkg/geoKdTree - url = https://github.com/travissluka/geoKdTree.git diff --git a/.testing/Makefile b/.testing/Makefile index 5d233d5fb0..ab978fdadc 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -20,7 +20,7 @@ MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.01 +FMS_COMMIT ?= 2019.01.03 FMS := $(DEPS)/fms #--- @@ -92,11 +92,34 @@ TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ $(wildcard build/target_codebase/config_src/ext*/*.F90) FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) +#--- +# Python preprocessing environment configuration + +HAS_NUMPY = $(shell python -c "import numpy" 2> /dev/null && echo "yes") +HAS_NETCDF4 = $(shell python -c "import netCDF4" 2> /dev/null && echo "yes") + +USE_VENV = +ifneq ($(HAS_NUMPY), yes) + USE_VENV = yes +endif +ifneq ($(HAS_NETCDF4), yes) + USE_VENV = yes +endif + +# When disabled, activation is a null operation (`true`) +VENV_PATH = +VENV_ACTIVATE = true +ifeq ($(USE_VENV), yes) + VENV_PATH = work/local-env + VENV_ACTIVATE = . $(VENV_PATH)/bin/activate +endif + + #--- # Rules .PHONY: all build.regressions -all: $(foreach b,$(BUILDS),build/$(b)/MOM6) +all: $(foreach b,$(BUILDS),build/$(b)/MOM6) $(VENV_PATH) build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) # Executable @@ -184,6 +207,18 @@ $(LIST_PATHS) $(MKMF): cd $(DEPS)/mkmf; git checkout $(MKMF_COMMIT) +#--- +# Python preprocessing +# NOTE: Some less mature environments (e.g. Arm64 Ubuntu) require explicit +# installation of numpy before netCDF4, as well as wheel and cython support. +work/local-env: + python3 -m venv $@ + . $@/bin/activate \ + && pip3 install wheel \ + && pip3 install cython \ + && pip3 install numpy \ + && pip3 install netCDF4 + #---- # Testing @@ -264,22 +299,9 @@ $(eval $(call CMP_RULE,regression,symmetric target)) # TODO: chksum_diag parsing of restart files - #--- # Test run output files -# Generalized MPI environment variable support -# XXX: Using `-env` in the MPICH test can erroneously producing an `nv` file. -# $(1): Environment variables -ifeq ($(shell $(MPIRUN) -x tmp=1 true 2> /dev/null ; echo $$?), 0) - MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) -else ifeq ($(shell $(MPIRUN) -env tmp=1 true 2> /dev/null ; echo $$? ; rm -f nv), 0) - MPIRUN_CMD=$(MPIRUN) $(if $(1),-env $(1),) -else - MPIRUN_CMD=$(1) $(MPIRUN) -endif - - # Rule to build work//{ocean.stats,chksum_diag}. # $(1): Test configuration name # $(2): Executable type @@ -293,24 +315,30 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 if [ $(3) ]; then find build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p $$(@D) cp -rL $$*/* $$(@D) - cd $$(@D) && if [ -f Makefile ]; then $(MAKE); fi + if [ -f $$(@D)/Makefile ]; then \ + $$(VENV_ACTIVATE) \ + && cd $$(@D) \ + && $(MAKE); \ + else \ + cd $$(@D); \ + fi mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override cd $$(@D) \ - && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> std.err > std.out \ + && $(5) $(MPIRUN) -n $(6) ../../../$$< 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ cat std.out | tee ../../../results/$$*/std.$(1).out | tail -20 ; \ - cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ - rm ocean.stats chksum_diag ; \ - echo -e "${FAIL}: $$*.$(1) failed at runtime." \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ + rm ocean.stats chksum_diag ; \ + echo -e "${FAIL}: $$*.$(1) failed at runtime." \ ) @echo -e "${DONE}: $$*.$(1); no runtime errors." if [ $(3) ]; then \ mkdir -p results/$$* ; \ bash <(curl -s https://codecov.io/bash) -n $$@ \ > work/$$*/codecov.$(1).out \ - 2> work/$$*/codecov.$(1).err ; \ + 2> work/$$*/codecov.$(1).err ; \ fi endef @@ -322,7 +350,7 @@ $(eval $(call STAT_RULE,symmetric,symmetric,$(REPORT_COVERAGE),,,1)) $(eval $(call STAT_RULE,asymmetric,asymmetric,,,,1)) $(eval $(call STAT_RULE,target,target,,,,1)) $(eval $(call STAT_RULE,repro,repro,,,,1)) -$(eval $(call STAT_RULE,openmp,openmp,,,,1)) +$(eval $(call STAT_RULE,openmp,openmp,,,GOMP_CPU_AFFINITY=0,1)) $(eval $(call STAT_RULE,layout,symmetric,,LAYOUT=2$(,)1,,2)) $(eval $(call STAT_RULE,rotate,symmetric,,ROTATE_INDEX=True\nINDEX_TURNS=1,,1)) $(eval $(call STAT_RULE,nan,symmetric,,,MALLOC_PERTURB_=256,1)) @@ -339,7 +367,13 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 rm -rf $(@D) mkdir -p $(@D) cp -rL $*/* $(@D) - cd work/$*/restart && if [ -f Makefile ]; then $(MAKE); fi + if [ -f $(@D)/Makefile ]; then \ + $(VENV_ACTIVATE) \ + && cd work/$*/restart \ + && $(MAKE); \ + else \ + cd work/$*/restart; \ + fi mkdir -p $(@D)/RESTART # Generate the half-period input namelist # TODO: Assumes that runtime set by DAYMAX, will fail if set by input.nml @@ -354,8 +388,8 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 cd $(@D) && $(MPIRUN) -n 1 ../../../$< 2> std1.err > std1.out \ || !( \ cat std1.out | tee ../../../results/$*/std.restart1.out | tail ; \ - cat std1.err | tee ../../../results/$*/std.restart1.err | tail ; \ - echo -e "${FAIL}: $*.restart failed at runtime." \ + cat std1.err | tee ../../../results/$*/std.restart1.err | tail ; \ + echo -e "${FAIL}: $*.restart failed at runtime." \ ) # Setup the next inputs cd $(@D) && rm -rf INPUT && mv RESTART INPUT @@ -365,8 +399,8 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 cd $(@D) && $(MPIRUN) -n 1 ../../../$< 2> std2.err > std2.out \ || !( \ cat std2.out | tee ../../../results/$*/std.restart2.out | tail ; \ - cat std2.err | tee ../../../results/$*/std.restart2.err | tail ; \ - echo -e "${FAIL}: $*.restart failed at runtime." \ + cat std2.err | tee ../../../results/$*/std.restart2.err | tail ; \ + echo -e "${FAIL}: $*.restart failed at runtime." \ ) # TODO: Restart checksum diagnostics diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index 6678c00578..1818390192 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -297,6 +297,10 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! v-points, and similarly at v-points. This option would ! have no effect on the SADOURNY Coriolis scheme if it ! were possible to use centered difference thickness fluxes. +PGF_STANLEY_T2_DET_COEFF = 0.5 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley form of the Brankart + ! correction. Negative values disable the scheme. ! === module MOM_hor_visc === LAPLACIAN = True @@ -426,6 +430,10 @@ KHTH = 1.0 ! [m2 s-1] default = 0.0 ! The background horizontal thickness diffusivity. KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 ! The maximum horizontal thickness diffusivity. +STANLEY_PRM_DET_COEFF = 0.5 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley parameterization. Negative + ! values disable the scheme. ! === module MOM_mixed_layer_restrat === FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 diff --git a/.testing/tc4/.gitignore b/.testing/tc4/.gitignore new file mode 100644 index 0000000000..29f62fb208 --- /dev/null +++ b/.testing/tc4/.gitignore @@ -0,0 +1,4 @@ +ocean_hgrid.nc +sponge.nc +temp_salt_ic.nc +topog.nc diff --git a/.testing/tc4/Makefile b/.testing/tc4/Makefile index c332bbd7e6..a9aa395b9c 100644 --- a/.testing/tc4/Makefile +++ b/.testing/tc4/Makefile @@ -1,3 +1,8 @@ -ocean_hgrid.nc topog.nc temp_salt_ic.nc sponge.nc: +OUT=ocean_hgrid.nc sponge.nc temp_salt_ic.nc topog.nc + +$(OUT): python build_grid.py python build_data.py + +clean: + rm -rf $(OUT) diff --git a/.travis.yml b/.travis.yml index 6bf509ce8c..10816b7122 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,6 +14,7 @@ addons: - mpich libmpich-dev - doxygen graphviz flex bison cmake - python-numpy python-netcdf4 + - python3 python3-dev python3-venv python3-pip - bc jobs: diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index a04ee426e6..7075fb7c10 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -9,10 +9,8 @@ module MOM_surface_forcing_gfdl 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_diag_mediator, only : diag_ctrl, safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg diff --git a/config_src/external/GFDL_ocean_BGC/README.md b/config_src/external/GFDL_ocean_BGC/README.md index 584e5aa16d..198575c8a7 100644 --- a/config_src/external/GFDL_ocean_BGC/README.md +++ b/config_src/external/GFDL_ocean_BGC/README.md @@ -3,4 +3,4 @@ GFDL_ocean_BGC These APIs reflect those for the GFDL ocean_BGC available at https://github.com/NOAA-GFDL/ocean_BGC. -The modules in this directory do not do any computations. They simple reflect the APIs of the above package. +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. diff --git a/config_src/external/ODA_hooks/README.md b/config_src/external/ODA_hooks/README.md new file mode 100644 index 0000000000..b26731a463 --- /dev/null +++ b/config_src/external/ODA_hooks/README.md @@ -0,0 +1,9 @@ +ODA_hooks +========= + +These APIs reflect those for the ocean data assimilation hooks similar to https://github.com/MJHarrison-GFDL/MOM6_DA_hooks + +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. + +- kdtree.f90 - would come from https://github.com/travissluka/geoKdTree +- ocean_da_core.F90, ocean_da_types.F90, write_ocean_obs.F90 were copied from https://github.com/MJHarrison-GFDL/MOM6_DA_hooks diff --git a/config_src/external/ODA_hooks/kdtree.f90 b/config_src/external/ODA_hooks/kdtree.f90 new file mode 100644 index 0000000000..a27716dde1 --- /dev/null +++ b/config_src/external/ODA_hooks/kdtree.f90 @@ -0,0 +1,12 @@ +!> A null version of K-d tree from geoKdTree +module kdtree + implicit none + private + + public :: kd_root + + !> A K-d tree tpe + type kd_root + integer :: dummy !< To stop a compiler from doing nothing + end type kd_root +end module kdtree diff --git a/config_src/external/ODA_hooks/ocean_da_core.F90 b/config_src/external/ODA_hooks/ocean_da_core.F90 new file mode 100644 index 0000000000..769e44b2aa --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_core.F90 @@ -0,0 +1,47 @@ +!> A set of dummy interfaces for compiling the MOM6 DA driver code. +module ocean_da_core_mod + ! MOM modules + use MOM_domains, only : MOM_domain_type, domain2D + use MOM_time_manager, only : time_type, set_time, get_date + ! ODA_tools modules + use ocean_da_types_mod, only : ocean_profile_type, grid_type + use kdtree, only : kd_root + + implicit none + private + public :: ocean_da_core_init + public :: get_profiles + +contains + + !> Initializes the MOM6 DA driver code. + subroutine ocean_da_core_init(Domain, global_grid, Profiles, model_time) + type(domain2D), pointer, intent(in) :: Domain !< A MOM domain type + type(grid_type), pointer, intent(in) :: global_grid !< The global ODA horizontal grid type + type(ocean_profile_type), pointer :: Profiles !< This is an unstructured recursive list of profiles + !! which are either within the localized domain corresponding + !! to the Domain argument, or the global profile list (type). + type(time_type), intent(in) :: model_time !< The current model time type. + + + + Profiles=>NULL() + return + end subroutine ocean_da_core_init + + + !> Get profiles obs within the current analysis interval + subroutine get_profiles(model_time, Profiles, Current_profiles) + type(time_type), intent(in) :: model_time !< The current analysis time. + type(ocean_profile_type), pointer :: Profiles !< The full recursive list of profiles. + type(ocean_profile_type), pointer :: Current_profiles !< A returned list of profiles for the + !! current analysis step. + + Profiles=>NULL() + Current_Profiles=>NULL() + + return + end subroutine get_profiles + + +end module ocean_da_core_mod diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 new file mode 100644 index 0000000000..bc5af1d782 --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -0,0 +1,85 @@ +!> Dummy aata structures and methods for ocean data assimilation. +module ocean_da_types_mod + + use MOM_time_manager, only : time_type + + implicit none + + private + + + !> Example type for ocean ensemble DA state + type, public :: OCEAN_CONTROL_STRUCT + integer :: ensemble_size + real, pointer, dimension(:,:,:) :: SSH=>NULL() !NULL() !NULL() !NULL() !NULL() !NULL() ! Example of a profile type + type, public :: ocean_profile_type + integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) + logical :: initialized !< a True value indicates that this profile has been allocated for use + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are + !! co-located in space-time + integer :: ensemble_size !< size of the ensemble of model states used in association with this profile + integer :: num_variables !< number of measurement types associated with this profile. + integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) + !! and instrument type (XBT, CDT, etc.) + integer :: levels !< number of levels in the current profile + integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + integer :: profile_flag !< an overall flag for the profile + real :: lat, lon !< latitude and longitude (degrees E and N) + logical :: accepted !< logical flag to disable a profile + type(time_type) :: time_window !< The time window associated with this profile [s] + real, pointer, dimension(:) :: obs_error !< The observation error by variable + real :: loc_dist !< The impact radius of this observation (m) + type(ocean_profile_type), pointer :: next=>NULL() !< all profiles are stored as linked list. + type(ocean_profile_type), pointer :: prev=>NULL() + type(ocean_profile_type), pointer :: cnext=>NULL() ! current profiles are stored as linked list. + type(ocean_profile_type), pointer :: cprev=>NULL() + integer :: nbr_xi, nbr_yi ! nearest neighbor model gridpoint for the profile + real :: nbr_dist ! distance to nearest neighbor model gridpoint + logical :: compute !< profile is within current compute domain + real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] + real, dimension(:,:), pointer :: data => NULL() !< data by variable type + integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type + real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess + real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis + type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator + type(time_type) :: time !< profile time type + real :: i_index, j_index !< model longitude and latitude indices respectively + real, dimension(:,:), pointer :: k_index !< model depth indices + type(time_type) :: tdiff !< difference between model time and observation time + character(len=128) :: filename + end type ocean_profile_type + + !> Example forward operator type. + type, public :: forward_operator_type + integer :: num + integer, dimension(2) :: state_size !< for + integer, dimension(:), pointer :: state_var_index !< for flattened data + integer, dimension(:), pointer :: i_index !< i-dimension index + integer, dimension(:), pointer :: j_index !< j-dimension index + real, dimension(:), pointer :: coef + end type forward_operator_type + + !> Grid type for DA + type, public :: grid_type + real, pointer, dimension(:,:) :: x=>NULL(), y=>NULL() + real, pointer, dimension(:,:,:) :: z=>NULL() + real, pointer, dimension(:,:,:) :: h=>NULL() + real, pointer, dimension(:,:) :: basin_mask => NULL() + real, pointer, dimension(:,:,:) :: mask => NULL() + real, pointer, dimension(:,:) :: bathyT => NULL() + logical :: tripolar_N + integer :: ni, nj, nk + end type grid_type + +end module ocean_da_types_mod diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 new file mode 100644 index 0000000000..a2c41b58d6 --- /dev/null +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -0,0 +1,50 @@ +!> Dummy interfaces for writing ODA data +module write_ocean_obs_mod + + + use ocean_da_types_mod, only : ocean_profile_type + use MOM_time_manager, only : time_type, get_time, set_date + + implicit none + + private + + public :: open_profile_file, write_profile, close_profile_file, & + write_ocean_obs_init + +contains + +!> Open a profile file +integer function open_profile_file(name, nvar, grid_lon, grid_lat,thread,fset) + character(len=*), intent(in) :: name !< File name + integer, intent(in), optional :: nvar !< Number of variables + real, dimension(:), optional, intent(in) :: grid_lon !< Longitude [degreeE] + real, dimension(:), optional, intent(in) :: grid_lat !< Latitude [degreeN] + integer, intent(in), optional :: thread !< Thread + integer, intent(in), optional :: fset !< File set + + open_profile_file=-1 +end function open_profile_file + +!> Write a profile +subroutine write_profile(unit,profile) + integer, intent(in) :: unit !< File unit + type(ocean_profile_type), intent(in) :: profile !< Profile + + return +end subroutine write_profile + +!> Close a profile file +subroutine close_profile_file(unit) + integer, intent(in) :: unit !< File unit + + return +end subroutine close_profile_file + +!> Initialize write_ocean_obs module +subroutine write_ocean_obs_init() + + return +end subroutine write_ocean_obs_init + +end module write_ocean_obs_mod diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 deleted file mode 100644 index 79bf924ca3..0000000000 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ /dev/null @@ -1,1203 +0,0 @@ -module MOM_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, November 1998 - May 2002 * -!* Edited by Stephen Griffies June 2014 * -!* * -!* This program contains the subroutines that calculate the * -!* surface wind stresses and fluxes of buoyancy or temperature and * -!* fresh water. These subroutines will be called every time step, * -!* even if the wind stresses or buoyancy fluxes are constant in time * -!* - in that case these routines return quickly without doing * -!* anything. In addition, any I/O of forcing fields is controlled * -!* by surface_forcing_init, located in this file. * -!* * -!* set_forcing is a small entry subroutine for the subroutines in * -!* this file. It provides the external access to these subroutines. * -!* * -!* wind_forcing determines the wind stresses and places them into * -!* taux[][] and tauy[][]. Often wind_forcing must be tailored for * -!* a particular application - either by specifying file and variable * -!* names or by providing appropriate internal expressions for the * -!* stresses. * -!* * -!* buoyancy_forcing determines the surface fluxes of buoyancy, * -!* temperature, and fresh water, as is appropriate. A restoring * -!* boundary condition is implemented, but the code for any other * -!* boundary condition will usually be modified - either to specify * -!* file and variable names and which time level to read, or to set * -!* an internal expression for the variables. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - -use MOM_constants, only : hlv, hlf -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All -use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_string_functions, only : uppercase -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags -use MOM_forcing_type, only : set_net_mass_forcing, copy_common_forcing_fields -use MOM_forcing_type, only : set_derived_forcing_fields -use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type -use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing -use MOM_get_input, only : Get_MOM_Input, directories -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data, MOM_read_vector, slasher -use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS -use MOM_restart, only : restart_init_end, save_restart, restore_state -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, set_time -use MOM_tracer_flow_control, only : call_tracer_set_forcing -use MOM_tracer_flow_control, only : tracer_flow_control_CS -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use user_surface_forcing, only : USER_wind_forcing, USER_buoyancy_forcing -use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS -use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init -use user_revise_forcing, only : user_revise_forcing_CS - -implicit none ; private - -#include - -public set_forcing -public surface_forcing_init -public forcing_diagnostics -public forcing_save_restart - -! surface_forcing_CS is a structure containing pointers to the forcing fields -! which may be used to drive MOM. All fluxes are positive into the ocean. -type, public :: surface_forcing_CS ; private - - logical :: use_temperature !< if true, temp & salinity used as state variables - logical :: restorebuoy !< if true, use restoring surface buoyancy forcing - logical :: adiabatic !< if true, no diapycnal mass fluxes or surface buoyancy forcing - logical :: variable_winds !< if true, wind stresses vary with time - logical :: variable_buoyforce !< if true, buoyancy forcing varies with time. - real :: south_lat !< southern latitude of the domain - real :: len_lat !< domain length in latitude - - real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] - real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] - real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] - real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] - - real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] - logical :: read_gust_2d !< if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-1 ~> Pa] - !< gust is used when read_gust_2d is true. - - real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] - real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [ppt] - real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [R ~> kg m-3] - - integer :: wind_last_lev_read = -1 !< The last time level read from the wind input files - integer :: buoy_last_lev_read = -1 !< The last time level read from buoyancy input files - - ! if WIND_CONFIG=='gyres' then use the following as = A, B, C and n respectively for - ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) - real :: gyres_taux_const !< A constant wind stress [Pa]. - real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. - real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. - real :: gyres_taux_n_pis !< The number of sine lobes in the basin if if WIND_CONFIG=='gyres' - - real :: T_north !< target temperatures at north used in buoyancy_forcing_linear - real :: T_south !< target temperatures at south used in buoyancy_forcing_linear - real :: S_north !< target salinity at north used in buoyancy_forcing_linear - real :: S_south !< target salinity at south used in buoyancy_forcing_linear - - logical :: first_call_set_forcing = .true. !< True until after the first call to set_forcing - - real :: wind_scale !< value by which wind-stresses are scaled, ND. - character(len=8) :: wind_stagger !< A character indicating how the wind stress components - !! are staggered in WIND_FILE. Valid values are A or C for now. - - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() !< A pointer to the structure - !! that is used to orchestrate the calling of tracer packages - type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure - - type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output - - character(len=200) :: inputdir !< directory where NetCDF input files are. - character(len=200) :: wind_config !< indicator for wind forcing type (2gyre, USER, FILE..) - character(len=200) :: wind_file !< if wind_config is "file", file to use - character(len=200) :: buoy_config !< indicator for buoyancy forcing type - - character(len=200) :: longwavedown_file = '' !< The file from which the downward longwave heat flux is read - character(len=200) :: shortwavedown_file = '' !< The file from which the downward shortwave heat flux is read - character(len=200) :: evaporation_file = '' !< The file from which the evaporation is read - character(len=200) :: sensibleheat_file = '' !< The file from which the sensible heat flux is read - character(len=200) :: latentheat_file = '' !< The file from which the latent heat flux is read - - character(len=200) :: precip_file = '' !< The file from which the rainfall is read - character(len=200) :: snow_file = '' !< The file from which the snowfall is read - character(len=200) :: freshdischarge_file = '' !< The file from which the runoff and calving are read - - character(len=200) :: longwaveup_file = '' !< The file from which the upward longwave heat flux is read - character(len=200) :: shortwaveup_file = '' !< The file from which the upward shorwave heat flux is read - - character(len=200) :: SSTrestore_file = '' !< The file from which to read the sea surface - !! temperature to restore toward - character(len=200) :: salinityrestore_file = '' !< The file from which to read the sea surface - !! salinity to restore toward - - character(len=80) :: stress_x_var = '' !< X-windstress variable name in the input file - character(len=80) :: stress_y_var = '' !< Y-windstress variable name in the input file - - type(forcing_diags), public :: handles !< A structure with diagnostics handles - - !>@{ Control structures for named forcing packages - type(user_revise_forcing_CS), pointer :: urf_CS => NULL() - type(user_surface_forcing_CS), pointer :: user_forcing_CSp => NULL() - ! type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() - !!@} -end type surface_forcing_CS - -integer :: id_clock_forcing - -contains - -!> This subroutine calls other subroutines in this file to get surface forcing fields. -!! It also allocates and initializes the fields in the flux type. -subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day_start !< The start time of the fluxes - type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: dt ! length of time over which fluxes applied [s] - type(time_type) :: day_center ! central time of the fluxes. - integer :: intdt - integer :: isd, ied, jsd, jed - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - call cpu_clock_begin(id_clock_forcing) - - day_center = day_start + day_interval/2 - call get_time(day_interval, intdt) - dt = real(intdt) - - if (CS%first_call_set_forcing) then - ! Allocate memory for the mechanical and thermodyanmic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) - - call allocate_forcing_type(G, fluxes, ustar=.true.) - if (trim(CS%buoy_config) /= "NONE") then - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) - call safe_alloc_ptr(CS%S_Restore, isd, ied, jsd, jed) - endif - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore, isd, ied, jsd, jed) - endif ! endif for CS%use_temperature - endif - endif - - ! calls to various wind options - if (CS%variable_winds .or. CS%first_call_set_forcing) then - if (trim(CS%wind_config) == "file") then - call wind_forcing_from_file(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "2gyre") then - call wind_forcing_2gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "1gyre") then - call wind_forcing_1gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "gyres") then - call wind_forcing_gyres(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "zero") then - call wind_forcing_zero(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "MESO") then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") -! call MESO_wind_forcing(sfc_state, forces, day_center, G, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "USER") then - call USER_wind_forcing(sfc_state, forces, day_center, G, CS%user_forcing_CSp) - elseif (CS%variable_winds .and. .not.CS%first_call_set_forcing) then - call MOM_error(FATAL, & - "MOM_surface_forcing: Variable winds defined with no wind config") - else - call MOM_error(FATAL, & - "MOM_surface_forcing:Unrecognized wind config "//trim(CS%wind_config)) - endif - endif - if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & - (.not.CS%adiabatic)) then - if (trim(CS%buoy_config) == "file") then - call buoyancy_forcing_from_files(sfc_state, fluxes, day_center, dt, G, US, CS) - elseif (trim(CS%buoy_config) == "zero") then - call buoyancy_forcing_zero(sfc_state, fluxes, day_center, dt, G, CS) - elseif (trim(CS%buoy_config) == "linear") then - call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) - elseif (trim(CS%buoy_config) == "MESO") then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") -! call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%MESO_forcing_CSp) - elseif (trim(CS%buoy_config) == "USER") then - call USER_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%user_forcing_CSp) - elseif (trim(CS%buoy_config) == "NONE") then - call MOM_mesg("MOM_surface_forcing: buoyancy forcing has been set to omitted.") - elseif (CS%variable_buoyforce .and. .not.CS%first_call_set_forcing) then - call MOM_error(FATAL, & - "MOM_surface_forcing: Variable buoy defined with no buoy config.") - else - call MOM_error(FATAL, & - "MOM_surface_forcing: Unrecognized buoy config "//trim(CS%buoy_config)) - endif - endif - - if (associated(CS%tracer_flow_CSp)) then - call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS%tracer_flow_CSp) - endif - - ! Allow for user-written code to alter the fluxes after all the above - call user_alter_forcing(sfc_state, fluxes, day_center, G, CS%urf_CS) - - ! Fields that exist in both the forcing and mech_forcing types must be copied. - if (CS%variable_winds .or. CS%first_call_set_forcing) then - call copy_common_forcing_fields(forces, fluxes, G) - call set_derived_forcing_fields(forces, fluxes, G, US, CS%Rho0) - endif - - if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & - (.not.CS%adiabatic)) then - call set_net_mass_forcing(fluxes, forces, G, US) - endif - - CS%first_call_set_forcing = .false. - - call cpu_clock_end(id_clock_forcing) -end subroutine set_forcing - -!> This subroutine allocates arrays for buoyancy forcing. -subroutine buoyancy_forcing_allocate(fluxes, G, CS) - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic - !! forcing fields that will be allocated here - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - integer :: isd, ied, jsd, jed - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - ! surface restoring fields - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(CS%S_Restore,isd,ied,jsd,jed) - endif - - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy,isd,ied,jsd,jed) - - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore,isd,ied,jsd,jed) - - endif ! endif for CS%use_temperature - -end subroutine buoyancy_forcing_allocate - - -! This subroutine sets the surface wind stresses to zero -subroutine wind_forcing_zero(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_zero, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - !set steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - if (CS%read_gust_2d) then - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z*CS%gust(i,j)/CS%Rho0) - enddo ; enddo ; endif - else - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z*CS%gust_const/CS%Rho0) - enddo ; enddo ; endif - endif - - call callTree_leave("wind_forcing_zero") -end subroutine wind_forcing_zero - - -!> This subroutine sets the surface wind stresses according to double gyre. -subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_2gyre, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - !set the steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.1*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_2gyre") -end subroutine wind_forcing_2gyre - - -!> This subroutine sets the surface wind stresses according to single gyre. -subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_1gyre, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! set the steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = -0.2*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_1gyre") -end subroutine wind_forcing_1gyre - - -!> This subroutine sets the surface wind stresses according to gyres. -subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI, y - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_gyres, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! steady surface wind stresses [Pa] - PI = 4.0*atan(1.0) - - do j=jsd,jed ; do I=IsdB,IedB - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * (CS%gyres_taux_const + & - ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & - + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) )) - enddo ; enddo - - do J=JsdB,JedB ; do i=isd,ied - forces%tauy(i,J) = 0.0 - enddo ; enddo - - ! set the friction velocity - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_S * (CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + forces%tauy(i,j)*forces%tauy(i,j) + & - forces%taux(i-1,j)*forces%taux(i-1,j) + forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0) ) - enddo ; enddo - - call callTree_leave("wind_forcing_gyres") -end subroutine wind_forcing_gyres - -!> This subroutine sets the surface wind stresses by reading a file. -subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - integer :: time_lev ! With fields from a file, this must - ! be reset, depending on the time. - character(len=200) :: filename ! The name of the input file. - real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. - real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress - ! units [R Z L T-2 Pa-1 ~> 1] - integer :: days, seconds - - call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - - call get_time(day,seconds,days) - time_lev = days - 365*floor(real(days) / 365.0) +1 - - if (time_lev /= CS%wind_last_lev_read) then - filename = trim(CS%inputdir) // trim(CS%wind_file) -! if (is_root_pe()) & -! write(*,'("Wind_forcing Reading time level ",I," last was ",I,".")')& -! time_lev-1,CS%wind_last_lev_read-1 - select case ( uppercase(CS%wind_stagger(1:1)) ) - case ("A") - temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 - call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & - temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & - timelevel=time_lev, scale=Pa_conversion) - - call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.5 * CS%wind_scale * (temp_x(i,j) + temp_x(i+1,j)) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.5 * CS%wind_scale * (temp_y(i,j) + temp_y(i,j+1)) - enddo ; enddo - - if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust(i,j) + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) ) / CS%Rho0) - enddo ; enddo - else - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) - enddo ; enddo - endif - case ("C") - call MOM_read_vector(filename,CS%stress_x_var, CS%stress_y_var, & - forces%taux(:,:), forces%tauy(:,:), & - G%Domain, timelevel=time_lev, & - scale=Pa_conversion) - if (CS%wind_scale /= 1.0) then - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = CS%wind_scale * forces%taux(I,j) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = CS%wind_scale * forces%tauy(i,J) - enddo ; enddo - endif - - call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) - if (CS%read_gust_2d) then - do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt( (CS%gust(i,j) + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2)))) * US%L_to_Z / CS%Rho0 ) - enddo ; enddo - else - do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) / CS%Rho0) ) - enddo ; enddo - endif - case default - call MOM_error(FATAL, "wind_forcing_from_file: Unrecognized stagger "//& - trim(CS%wind_stagger)//" is not 'A' or 'C'.") - end select - CS%wind_last_lev_read = time_lev - endif ! time_lev /= CS%wind_last_lev_read - - call callTree_leave("wind_forcing_from_file") -end subroutine wind_forcing_from_file - - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water -!! by reading a file. It may also be modified to add surface fluxes of user provided tracers. -subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - real :: rhoXcp ! mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. - real :: Irho0 ! inverse Boussinesq reference density [m3 kg-1]. - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - - integer :: time_lev ! With fields from a file, this must - ! be reset, depending on the time. - integer :: time_lev_monthly ! With fields from a file, this must - ! be reset, depending on the time. - integer :: days, seconds - real, dimension(SZI_(G),SZJ_(G)) :: & - temp, & ! A 2-d temporary work array with various units. - SST_anom, & ! Instantaneous sea surface temperature anomalies from a - ! target (observed) value [degC]. - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value [ppt]. - SSS_mean ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation - ! anomalies [ppt]. - - call callTree_enter("buoyancy_forcing_from_files, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p - Irho0 = 1.0/(US%R_to_kg_m3*CS%Rho0) - - ! Read the file containing the buoyancy forcing. - call get_time(day,seconds,days) - - time_lev = days - 365*floor(real(days) / 365.0) - - if (time_lev < 31) then ; time_lev_monthly = 0 - else if (time_lev < 59) then ; time_lev_monthly = 1 - else if (time_lev < 90) then ; time_lev_monthly = 2 - else if (time_lev < 120) then ; time_lev_monthly = 3 - else if (time_lev < 151) then ; time_lev_monthly = 4 - else if (time_lev < 181) then ; time_lev_monthly = 5 - else if (time_lev < 212) then ; time_lev_monthly = 6 - else if (time_lev < 243) then ; time_lev_monthly = 7 - else if (time_lev < 273) then ; time_lev_monthly = 8 - else if (time_lev < 304) then ; time_lev_monthly = 9 - else if (time_lev < 334) then ; time_lev_monthly = 10 - else ; time_lev_monthly = 11 - endif - - time_lev = time_lev+1 - time_lev_monthly = time_lev_monthly+1 - - if (time_lev /= CS%buoy_last_lev_read) then - -! if (is_root_pe()) & -! write(*,'("buoyancy_forcing : Reading time level ",I3,", last was ",I3,".")')& -! time_lev,CS%buoy_last_lev_read - - - call MOM_read_data(trim(CS%inputdir)//trim(CS%longwavedown_file), "lwdn_sfc", & - fluxes%LW(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - call MOM_read_data(trim(CS%inputdir)//trim(CS%longwaveup_file), "lwup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%evaporation_file), "evap", & - fluxes%evap(:,:), G%Domain, timelevel=time_lev, scale=-US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%sensibleheat_file), "shflx", & - fluxes%sens(:,:), G%Domain, timelevel=time_lev, scale=-US%W_m2_to_QRZ_T) - - call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwavedown_file), "swdn_sfc", & - fluxes%sw(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwaveup_file), "swup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - do j=js,je ; do i=is,ie - fluxes%sw(i,j) = fluxes%sw(i,j) - temp(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%snow_file), "snow", & - fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) - call MOM_read_data(trim(CS%inputdir)//trim(CS%precip_file), "precip", & - fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_w", & - temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%lrunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) - enddo ; enddo - call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_s", & - temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%frunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) - enddo ; enddo - -! Read the SST and SSS fields for damping. - if (CS%restorebuoy) then - call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "TEMP", & - CS%T_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - call MOM_read_data(trim(CS%inputdir)//trim(CS%salinityrestore_file), "SALT", & - CS%S_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - endif - CS%buoy_last_lev_read = time_lev - - ! mask out land points and compute heat content of water fluxes - ! assume liquid precip enters ocean at SST - ! assume frozen precip enters ocean at 0degC - ! assume liquid runoff enters ocean at SST - ! assume solid runoff (calving) enters ocean at 0degC - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = fluxes%evap(i,j) * G%mask2dT(i,j) - fluxes%lprec(i,j) = fluxes%lprec(i,j) * G%mask2dT(i,j) - fluxes%fprec(i,j) = fluxes%fprec(i,j) * G%mask2dT(i,j) - fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * G%mask2dT(i,j) - fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * G%mask2dT(i,j) - fluxes%LW(i,j) = fluxes%LW(i,j) * G%mask2dT(i,j) - fluxes%sens(i,j) = fluxes%sens(i,j) * G%mask2dT(i,j) - fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) - fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) - - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p * fluxes%lrunoff(i,j)*sfc_state%SST(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion - enddo ; enddo - - endif ! time_lev /= CS%buoy_last_lev_read - - if (CS%restorebuoy) then - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & - (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & - (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) - else - fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - endif - enddo ; enddo - else - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const / CS%Rho0) - else - fluxes%buoy(i,j) = 0.0 - endif - enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - call callTree_leave("buoyancy_forcing_from_files") -end subroutine buoyancy_forcing_from_files - - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water. -!! It may also be modified to add surface fluxes of user provided tracers. -!! This case has zero surface buoyancy forcing. -subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_zero, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - call callTree_leave("buoyancy_forcing_zero") -end subroutine buoyancy_forcing_zero - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water. -!! It may also be modified to add surface fluxes of user provided tracers. -subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: y, T_restore, S_restore - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_linear, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - ! This case has no surface buoyancy forcing. - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - T_restore = CS%T_south + (CS%T_north-CS%T_south)*y - S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & - (S_Restore - sfc_state%SSS(i,j)) / & - (0.5*(sfc_state%SSS(i,j) + S_Restore)) - else - fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - endif - enddo ; enddo - else - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "RESTOREBUOY to linear not written yet.") - !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then - ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * CS%Flux_const / CS%Rho0) - ! else - ! fluxes%buoy(i,j) = 0.0 - ! endif - !enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - call callTree_leave("buoyancy_forcing_linear") -end subroutine buoyancy_forcing_linear - -!> Save any restart files associated with the surface forcing. -subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & - filename_suffix) - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to surface_forcing_init - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time !< The current model time - character(len=*), intent(in) :: directory !< The directory into which to write the - !! restart files - logical, optional, intent(in) :: time_stamped !< If true, the restart file names include - !! a unique time stamp. The default is false. - character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time- - !! stamp) to append to the restart file names. - - if (.not.associated(CS)) return - if (.not.associated(CS%restart_CSp)) return - - call save_restart(directory, Time, 1, G, CS%restart_CSp, time_stamped) - -end subroutine forcing_save_restart - -!> Initialize the surface forcing, including setting parameters and allocating permanent memory. -subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_CSp) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure - !! for this module - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< A pointer to the control structure of - !! the tracer flow control module. - - ! Local variables - type(directories) :: dirs - logical :: new_sim - type(time_type) :: Time_frc -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. - character(len=60) :: axis_units - character(len=200) :: filename, gust_file ! The name of the gustiness input file. - - if (associated(CS)) then - call MOM_error(WARNING, "surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - - id_clock_forcing=cpu_clock_id('(Ocean surface forcing)', grain=CLOCK_MODULE) - call cpu_clock_begin(id_clock_forcing) - - CS%diag => diag - if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) - call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & - "The directory in which all input files are found.", & - default=".") - CS%inputdir = slasher(CS%inputdir) - - call get_param(param_file, mdl, "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is "//& - "true. This assumes that KD = KDML = 0.0 and that "//& - "there is no buoyancy forcing, but makes the model "//& - "faster by eliminating subroutine calls.", default=.false.) - call get_param(param_file, mdl, "VARIABLE_WINDS", CS%variable_winds, & - "If true, the winds vary in time after the initialization.", & - default=.true.) - call get_param(param_file, mdl, "VARIABLE_BUOYFORCE", CS%variable_buoyforce, & - "If true, the buoyancy forcing varies in time after the "//& - "initialization of the model.", default=.true.) - - call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & - "The character string that indicates how buoyancy forcing "//& - "is specified. Valid options include (file), (zero), "//& - "(linear), (USER), and (NONE).", default="zero") - if (trim(CS%buoy_config) == "file") then - call get_param(param_file, mdl, "LONGWAVEDOWN_FILE", CS%longwavedown_file, & - "The file with the downward longwave heat flux, in "//& - "variable lwdn_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "LONGWAVEUP_FILE", CS%longwaveup_file, & - "The file with the upward longwave heat flux, in "//& - "variable lwup_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & - "The file with the evaporative moisture flux, in "//& - "variable evap.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & - "The file with the sensible heat flux, in "//& - "variable shflx.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEUP_FILE", CS%shortwaveup_file, & - "The file with the upward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEDOWN_FILE", CS%shortwavedown_file, & - "The file with the downward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & - "The file with the downward frozen precip flux, in "//& - "variable snow.", fail_if_missing=.true.) - call get_param(param_file, mdl, "PRECIP_FILE", CS%precip_file, & - "The file with the downward total precip flux, in "//& - "variable precip.", fail_if_missing=.true.) - call get_param(param_file, mdl, "FRESHDISCHARGE_FILE", CS%freshdischarge_file, & - "The file with the fresh and frozen runoff/calving fluxes, "//& - "invariables disch_w and disch_s.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in "//& - "variable TEMP.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SALINITYRESTORE_FILE", CS%salinityrestore_file, & - "The file with the surface salinity toward which to "//& - "restore in variable SALT.", fail_if_missing=.true.) - endif - call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & - "The character string that indicates how wind forcing "//& - "is specified. Valid options include (file), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", default="zero") - if (trim(CS%wind_config) == "file") then - call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & - "The file in which the wind stresses are found in "//& - "variables STRESS_X and STRESS_Y.", fail_if_missing=.true.) - call get_param(param_file, mdl, "WINDSTRESS_X_VAR",CS%stress_x_var, & - "The name of the x-wind stress variable in WIND_FILE.", & - default="STRESS_X") - call get_param(param_file, mdl, "WINDSTRESS_Y_VAR", CS%stress_y_var, & - "The name of the y-wind stress variable in WIND_FILE.", & - default="STRESS_Y") - call get_param(param_file, mdl, "WIND_STAGGER",CS%wind_stagger, & - "A character indicating how the wind stress components "//& - "are staggered in WIND_FILE. This may be A or C for now.", & - default="C") - call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & - "A value by which the wind stresses in WIND_FILE are rescaled.", & - default=1.0, units="nondim") - endif - if (trim(CS%wind_config) == "gyres") then - call get_param(param_file, mdl, "TAUX_CONST", CS%gyres_taux_const, & - "With the gyres wind_config, the constant offset in the "//& - "zonal wind stress profile: "//& - " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_SIN_AMP",CS%gyres_taux_sin_amp, & - "With the gyres wind_config, the sine amplitude in the "//& - "zonal wind stress profile: "//& - " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_COS_AMP",CS%gyres_taux_cos_amp, & - "With the gyres wind_config, the cosine amplitude in "//& - "the zonal wind stress profile: "//& - " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & - "With the gyres wind_config, the number of gyres in "//& - "the zonal wind stress profile: "//& - " n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="nondim", default=0.0) - endif - call get_param(param_file, mdl, "SOUTHLAT", CS%south_lat, & - "The southern latitude of the domain or the equivalent "//& - "starting value for the y-axis.", units=axis_units, default=0.) - call get_param(param_file, mdl, "LENLAT", CS%len_lat, & - "The latitudinal or y-direction length of the domain.", & - units=axis_units, fail_if_missing=.true.) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & - "The latent heat of fusion.", default=hlf, & - units="J/kg", scale=US%J_kg_to_Q) - call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & - "The latent heat of fusion.", default=hlv, units="J/kg", scale=US%J_kg_to_Q) - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes to the relative "//& - "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) - if (trim(CS%buoy_config) == "linear") then - call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & - "With buoy_config linear, the sea surface temperature "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & - "With buoy_config linear, the sea surface temperature "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & - "With buoy_config linear, the sea surface salinity "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & - "With buoy_config linear, the sea surface salinity "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - endif - endif - call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) - call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from "//& - "an input file", default=.false.) - if (CS%read_gust_2d) then - call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in "//& - "variable gustiness.", fail_if_missing=.true.) - call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) ; CS%gust(:,:) = 0.0 - filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'gustiness',CS%gust,G%domain, timelevel=1, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa - endif - call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") - -! All parameter settings are now known. - - if (trim(CS%wind_config) == "USER" .or. trim(CS%buoy_config) == "USER" ) then - call USER_surface_forcing_init(Time, G, param_file, diag, CS%user_forcing_CSp) - elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") - endif - - call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) - - ! Set up any restart fields associated with the forcing. - call restart_init(G, param_file, CS%restart_CSp, "MOM_forcing.res") - call restart_init_end(CS%restart_CSp) - - if (associated(CS%restart_CSp)) then - call Get_MOM_Input(dirs=dirs) - - new_sim = .false. - if ((dirs%input_filename(1:1) == 'n') .and. & - (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. - if (.not.new_sim) then - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) - endif - endif - - call user_revise_forcing_init(param_file, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) -end subroutine surface_forcing_init - -!> Clean up and deallocate any memory associated with this module and its children. -subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous surface_forcing_init call - !! that will be deallocated here. - type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to any possible - !! forcing fields that will be deallocated here. - - if (present(fluxes)) call deallocate_forcing_type(fluxes) - - if (associated(CS)) deallocate(CS) - CS => NULL() - -end subroutine surface_forcing_end - -end module MOM_surface_forcing diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index f2c5099544..9113b60c64 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -1,4 +1,4 @@ -program SHELF_main +program Shelf_main ! This file is part of MOM6. See LICENSE.md for the license. @@ -21,92 +21,104 @@ program SHELF_main !* * !********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end - use MOM_cpu_clock, only : CLOCK_COMPONENT - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end - use MOM_domains, only : MOM_infra_init, MOM_infra_end - use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe - use MOM_file_parser, only : get_param, log_param, log_version, param_file_type - use MOM_file_parser, only : close_param_file -! use MOM_grid, only : ocean_grid_type - use MOM_get_input, only : Get_MOM_Input, directories - use MOM_io, only : file_exists, open_file, close_file - use MOM_io, only : check_nml_error, io_infra_init, io_infra_end - use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE - use MOM_restart, only : save_restart -! use MOM_sum_output, only : write_energy, accumulate_net_input -! use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS - use MOM_string_functions, only : uppercase -! use MOM_surface_forcing, only : set_forcing, average_forcing -! use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS - use MOM_time_manager, only : time_type, set_date, set_time, get_date, time_type_to_real - use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) - use MOM_time_manager, only : operator(>), operator(<), operator(>=) - use MOM_time_manager, only : increment_date, set_calendar_type, month_name - use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS - use MOM_time_manager, only : NO_CALENDAR - use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init - use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end + use MOM_cpu_clock, only : CLOCK_COMPONENT + use MOM_debugging, only : MOM_debugging_init + use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init + use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end + use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration + use MOM_domains, only : MOM_infra_init, MOM_infra_end + use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var + use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid + use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe + use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint + use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type + use MOM_file_parser, only : close_param_file + use MOM_fixed_initialization, only : MOM_initialize_fixed + use MOM_get_input, only : Get_MOM_Input, directories + use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end + use MOM_hor_index, only : hor_index_type, hor_index_init + use MOM_io, only : MOM_io_init, file_exists, open_file, close_file + use MOM_io, only : check_nml_error, io_infra_init, io_infra_end + use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE + use MOM_open_boundary, only : ocean_OBC_type + use MOM_restart, only : save_restart + use MOM_string_functions,only : uppercase + use MOM_time_manager, only : time_type, set_date, get_date + use MOM_time_manager, only : real_to_time, time_type_to_real + use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) + use MOM_time_manager, only : operator(>), operator(<), operator(>=) + use MOM_time_manager, only : increment_date, set_calendar_type, month_name + use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR + use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid + use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init + use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd + use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init + use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf -! , add_shelf_flux_forcing, add_shelf_flux_IOB + implicit none #include - -! type(forcing) :: fluxes ! A structure that will be uninitialized till i figure out - ! whether i can make the argument optional - -! type(ocean_grid_type), pointer :: grid ! A pointer to a structure containing - ! metrics and related information. logical :: use_ice_shelf = .false. ! If .true., use the ice shelf model for ! part of the domain. - logical :: permit_restart = .true. ! This is .true. if incremental restart - ! files may be saved. - integer :: m, n - - integer :: nmax=2000000000; ! nmax is the number of iterations - ! after which to stop so that the - ! simulation does not exceed its CPU - ! time limit. nmax is determined by - ! evaluating the CPU time used between - ! successive calls to write_energy. - ! Initially it is set to be very large. - type(directories) :: dirs ! A structure containing several relevant directory paths. - - type(time_type), target :: Time ! A copy of the model's time. - ! Other modules can set pointers to this and - ! change it to manage diagnostics. - - type(time_type) :: Master_Time ! The ocean model's master clock. No other - ! modules are ever given access to this. - - type(time_type) :: Time1 ! The value of the ocean model's time at the - ! start of a call to step_MOM. - - type(time_type) :: Start_time ! The start time of the simulation. + ! This is .true. if incremental restart files may be saved. + logical :: permit_incr_restart = .true. + + integer :: ns ! Running number of external timesteps. + integer :: ns_ice ! Running number of internal timesteps in solo_step_ice_shelf. + + ! nmax is the number of iterations after which to stop so that the simulation does not exceed its + ! CPU time limit. nmax is determined by evaluating the CPU time used between successive calls to + ! write_cputime. Initially it is set to be very large. + integer :: nmax=2000000000 + + ! A structure containing several relevant directory paths. + type(directories) :: dirs + + ! A suite of time types for use by the solo ice model. + type(time_type), target :: Time ! A copy of the model's time. + ! Other modules can set pointers to this and + ! change it to manage diagnostics. + type(time_type) :: Master_Time ! The ocean model's master clock. No other + ! modules are ever given access to this. + type(time_type) :: Time1 ! The value of the ocean model's time at the + ! start of a call to step_MOM. + type(time_type) :: Start_time ! The start time of the simulation. type(time_type) :: segment_start_time ! The start time of this run segment. + type(time_type) :: Time_end ! End time for the segment or experiment. + type(time_type) :: restart_time ! The next time to write restart files. + type(time_type) :: Time_step_shelf ! A time_type version of time_step. + type(time_type) :: time_chg ! An amount of time to adjust the segment_start_time + ! and elapsed time to avoid roundoff problems. - type(time_type) :: Time_end ! End time for the segment or experiment. + real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. - type(time_type) :: restart_time ! The next time to write restart files. - - type(time_type) :: Time_step_shelf ! A time_type version of time_step. + logical :: elapsed_time_master ! If true, elapsed time is used to set the + ! model's master clock (Time). This is needed + ! if Time_step_shelf is not an exact + ! representation of time_step. + real :: time_step ! The time step [s] - real :: elapsed_time = 0.0 ! Elapsed time in this run in seconds. (years?) + ! A pointer to a structure containing metrics and related information. + type(ocean_grid_type), pointer :: ocn_grid - logical :: elapsed_time_master ! If true, elapsed time is used to set the - ! model's master clock (Time). This is needed - ! if Time_step_shelf is not an exact - ! representation of time_step. + type(dyn_horgrid_type), pointer :: dG => NULL() ! A dynamic version of the horizontal grid + type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the ocean vertical grid structure - real :: time_step ! The time step (in years??? seconds???) + !> Pointer to the MOM open boundary condition type + type(ocean_OBC_type), pointer :: OBC => NULL() + ! A pointer to a structure containing dimensional unit scaling factors. + type(unit_scale_type), pointer :: US + type(diag_ctrl), pointer :: & + diag => NULL() ! A pointer to the diagnostic regulatory structure integer :: Restart_control ! An integer that is bit-tested to determine whether ! incremental restart files are saved and whether they @@ -114,41 +126,40 @@ program SHELF_main ! files and +2 (bit 1) for time-stamped files. A ! restart file is saved at the end of a run segment ! unless Restart_control is negative. - real :: Time_unit ! The time unit in seconds for the following input fields. + + real :: Time_unit ! The time unit for the following input fields [s]. type(time_type) :: restint ! The time between saves of the restart file. type(time_type) :: daymax ! The final day of the simulation. - integer :: date_init(6)=0 ! The start date of the whole simulation. - integer :: date(6)=-1 ! Possibly the start date of this run segment. + integer :: CPU_steps ! The number of steps between writing CPU time. + integer :: date_init(6)=0 ! The start date of the whole simulation. + integer :: date(6)=-1 ! Possibly the start date of this run segment. integer :: years=0, months=0, days=0 ! These may determine the segment run integer :: hours=0, minutes=0, seconds=0 ! length, if read from a namelist. - integer :: yr, mon, day, hr, min, sec ! Temp variables for writing the date. - type(param_file_type) :: param_file ! The structure indicating the file(s) - ! containing all run-time parameters. - character(len=9) :: month + integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. + type(param_file_type) :: param_file ! The structure indicating the file(s) + ! containing all run-time parameters. + character(len=9) :: month character(len=16) :: calendar = 'julian' integer :: calendar_type=-1 integer :: unit, io_status, ierr - logical :: unit_in_use + logical :: symmetric + logical :: unit_in_use integer :: initClock, mainClock, termClock -! type(ice_shelf_CS), pointer :: MOM_CSp => NULL() -! type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() -! type(sum_output_CS), pointer :: sum_output_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() !----------------------------------------------------------------------- - character(len=4), parameter :: vers_num = 'v2.0' -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "SHELF_main (ice_shelf_driver)" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mod_name = "SHELF_main (ice_shelf_driver)" ! This module's name. namelist /ice_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds - !======================================================================= + !===================================================================== call write_cputime_start_clock(write_CPU_CSp) @@ -160,15 +171,16 @@ program SHELF_main termClock = cpu_clock_id( 'Termination' ) call cpu_clock_begin(initClock) - call MOM_mesg('======== Model being driven by ice_shelf_driver ========') + call MOM_mesg('======== Model being driven by ice_shelf_driver ========', 2) + call callTree_waypoint("Program Shelf_main, ice_shelf_driver.F90") if (file_exists('input.nml')) then ! Provide for namelist specification of the run length and calendar data. call open_file(unit, 'input.nml', form=ASCII_FILE, action=READONLY_FILE) read(unit, ice_solo_nml, iostat=io_status) call close_file(unit) + ierr = check_nml_error(io_status,'ice_solo_nml') if (years+months+days+hours+minutes+seconds > 0) then - ierr = check_nml_error(io_status,'ice_solo_nml') if (is_root_pe()) write(*,ice_solo_nml) endif endif @@ -184,38 +196,40 @@ program SHELF_main else calendar = uppercase(calendar) if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN - else if (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN - else if (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP - else if (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS - else if (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR - else if (calendar(1:1) /= ' ') then - call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar') + elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN + elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP + elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS + elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR + elseif (calendar(1:1) /= ' ') then + call MOM_error(FATAL,'Shelf_driver: Invalid namelist value '//trim(calendar)//' for calendar') else - call MOM_error(FATAL,'MOM_driver: No namelist value for calendar') + call MOM_error(FATAL,'Shelf_driver: No namelist value for calendar') endif endif call set_calendar_type(calendar_type) + if (sum(date_init) > 0) then Start_time = set_date(date_init(1),date_init(2), date_init(3), & date_init(4),date_init(5),date_init(6)) else - Start_time = set_time(0,0) + Start_time = real_to_time(0.0) endif call Get_MOM_Input(param_file, dirs) + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, US) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mod_name, version, "") - call get_param(param_file, mdl, "ICE_SHELF", use_ice_shelf, & + call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & "If true, call the code to apply an ice shelf model over "//& "some of the domain.", default=.false.) - if (.not.use_ice_shelf) call MOM_error(FATAL, & - "shelf_driver: ICE_SHELF must be defined.") + if (.not.use_ice_shelf) call MOM_error(FATAL, "Shelf_driver: Run stops unless ICE_SHELF is true.") - call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", time_step, & + call get_param(param_file, mod_name, "ICE_VELOCITY_TIMESTEP", time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics.", & units="s", fail_if_missing=.true.) @@ -224,39 +238,70 @@ program SHELF_main ! In this case, the segment starts at a time fixed by ocean_solo.res segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) Time = segment_start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) else - ! In this case, the segment starts at a time read from the MOM restart file - ! or left as Start_time by MOM_initialize. + ! In this case, the segment starts at Start_time. Time = Start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) endif + + ! This is the start of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("Start of ice shelf initialization.") + + call MOM_debugging_init(param_file) + call diag_mediator_infrastructure_init() + call MOM_io_init(param_file) + + ! Set up the ocean model domain and grid; the ice model grid is set in initialize_ice_shelf, + ! but the grids have strong commonalities in this configuration, and the ocean grid is required + ! to set up the diag mediator control structure. + call MOM_domains_init(ocn_grid%domain, param_file) + call hor_index_init(ocn_grid%Domain, HI, param_file) + call create_dyn_horgrid(dG, HI) + call clone_MOM_domain(ocn_grid%Domain, dG%Domain) + + ! Initialize the ocean grid and topography. + call MOM_initialize_fixed(dG, US, OBC, param_file, .true., dirs%output_directory) + call MOM_grid_init(ocn_grid, param_file, US, HI) + call copy_dyngrid_to_MOM_grid(dG, ocn_grid, US) + call destroy_dyn_horgrid(dG) + + ! Initialize the diag mediator. The ocean's vertical grid is not really used here, but at + ! present the interface to diag_mediator_init assumes the presence of ocean-specific information. + call verticalGridInit(param_file, GV, US) + call diag_mediator_init(ocn_grid, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + + call callTree_waypoint("returned from diag_mediator_init()") + + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag) + + ! This is the end of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("End of ice shelf initialization.") + Master_Time = Time ! grid => ice_shelf_CSp%grid segment_start_time = Time elapsed_time = 0.0 - Time_step_shelf = set_time(int(floor(time_step+0.5))) + Time_step_shelf = real_to_time(time_step) elapsed_time_master = (abs(time_step - time_type_to_real(Time_step_shelf)) > 1.0e-12*time_step) if (elapsed_time_master) & - call MOM_mesg("Using real elapsed time for the master clock.") + call MOM_mesg("Using real elapsed time for the master clock.", 2) ! Determine the segment end time, either from the namelist file or parsed input file. - call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & + call get_param(param_file, mod_name, "TIMEUNIT", Time_unit, & "The time unit for DAYMAX and RESTINT.", & units="s", default=86400.0) if (years+months+days+hours+minutes+seconds > 0) then Time_end = increment_date(Time, years, months, days, hours, minutes, seconds) - call MOM_mesg('Segment run length determied from ice_solo_nml.', 2) - call get_param(param_file, mdl, "DAYMAX", daymax, & + call MOM_mesg('Segment run length determined from ice_solo_nml.', 2) + call get_param(param_file, mod_name, "DAYMAX", daymax, & "The final time of the whole simulation, in units of "//& "TIMEUNIT seconds. This also sets the potential end "//& "time of the present run segment if the end time is "//& "not set (as it was here) via ocean_solo_nml in input.nml.", & timeunit=Time_unit, default=Time_end) else - call get_param(param_file, mdl, "DAYMAX", daymax, & + call get_param(param_file, mod_name, "DAYMAX", daymax, & "The final time of the whole simulation, in units of "//& "TIMEUNIT seconds. This also sets the potential end "//& "time of the present run segment if the end time is "//& @@ -265,58 +310,62 @@ program SHELF_main Time_end = daymax endif - if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), & - "TIme_end", time_type_to_real(Time_end) if (Time >= Time_end) call MOM_error(FATAL, & - "MOM_driver: The run has been started at or after the end time of the run.") + "Shelf_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, & + call get_param(param_file, mod_name, "RESTART_CONTROL", Restart_control, & "An integer whose bits encode which restart files are "//& "written. Add 2 (bit 1) for a time-stamped file, and odd "//& "(bit 0) for a non-time-stamped file. A non-time-stamped "//& "restart file is saved at the end of the run segment "//& "for any non-negative value.", default=1) - call get_param(param_file, mdl, "RESTINT", restint, & + call get_param(param_file, mod_name, "RESTINT", restint, & "The interval between saves of the restart file in units "//& "of TIMEUNIT. Use 0 (the default) to not save "//& - "incremental restart files at all.", default=set_time(0), & + "incremental restart files at all.", default=real_to_time(0.0), & timeunit=Time_unit) - call log_param(param_file, mdl, "ELAPSED TIME AS MASTER", elapsed_time_master) + call get_param(param_file, mod_name, "WRITE_CPU_STEPS", cpu_steps, & + "The number of coupled timesteps between writing the cpu "//& + "time. If this is not positive, do not check cpu time, and "//& + "the segment run-length can not be set via an elapsed CPU time.", & + default=1000) -! i don't think we'll use this... - call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & - write_CPU_CSp) - call MOM_mesg("Done MOM_write_cputime_init.", 5) + call log_param(param_file, mod_name, "ELAPSED TIME AS MASTER", elapsed_time_master) + if (cpu_steps > 0) & + call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & + write_CPU_CSp) ! Close the param_file. No further parsing of input is possible after this. call close_param_file(param_file) -! call diag_mediator_close_registration(diag) + call diag_mediator_close_registration(diag) ! Write out a time stamp file. - call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & - threading=SINGLE_FILE) - call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call close_file(unit) - - call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (calendar_type /= NO_CALENDAR) then + call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & + threading=SINGLE_FILE) + call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + call close_file(unit) + endif + + if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & - .or. (Restart_control < 0)) permit_restart = .false. + .or. (Restart_control < 0)) permit_incr_restart = .false. - if (restint > set_time(0)) then + if (restint > real_to_time(0.0)) then ! restart_time is the next integral multiple of restint. restart_time = Start_time + restint * & - (1 + ((Time + Time_step_ocean) - Start_time) / restint) + (1 + ((Time + Time_step_shelf) - Start_time) / restint) else ! Set the time so late that there is no intermediate restart. - restart_time = Time_end + Time_step_ocean - permit_restart = .false. + restart_time = Time_end + Time_step_shelf + permit_incr_restart = .false. endif call cpu_clock_end(initClock) !end initialization @@ -325,66 +374,72 @@ program SHELF_main !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MAIN LOOP !!!!!!!!!!!!!!!!!!!!!!!!!!!!! - n = 1 ; m = 1 - do while ((n < nmax) .and. (Time < Time_end)) + ns = 1 ; ns_ice = 1 + do while ((ns < nmax) .and. (Time < Time_end)) + call callTree_enter("Main loop, Shelf_driver.F90", ns) ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, m, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time) -! Time = Time + Time_step_ocean -! This is here to enable fractional-second time steps. +! Time = Time + Time_step_shelf +! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + time_step if (elapsed_time > 2e9) then - ! This is here to ensure that the conversion from a real to an integer - ! can be accurately represented in long runs (longer than ~63 years). - ! It will also ensure that elapsed time does not loose resolution of order - ! the timetype's resolution, provided that the timestep and tick are - ! larger than 10-5 seconds. If a clock with a finer resolution is used, - ! a smaller value would be required. - segment_start_time = segment_start_time + set_time(int(floor(elapsed_time))) - elapsed_time = elapsed_time - floor(elapsed_time) + ! This is here to ensure that the conversion from a real to an integer can be accurately + ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time + ! does not lose resolution of order the timetype's resolution, provided that the timestep and + ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller + ! value would be required. + time_chg = real_to_time(elapsed_time) + segment_start_time = segment_start_time + time_chg + elapsed_time = elapsed_time - time_type_to_real(time_chg) endif if (elapsed_time_master) then - Master_Time = segment_start_time + set_time(int(floor(elapsed_time+0.5))) + Master_Time = segment_start_time + real_to_time(elapsed_time) else Master_Time = Master_Time + Time_step_shelf endif Time = Master_Time + if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then + call write_cputime(Time, ns, nmax, write_CPU_CSp) + endif ; endif + ! See if it is time to write out a restart file - timestamped or not. - if (permit_restart) then - if (Time + (Time_step_shelf/2) > restart_time) then - if (BTEST(Restart_control,1)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) - endif - if (BTEST(Restart_control,0)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) - endif - restart_time = restart_time + restint + if ((permit_incr_restart) .and. (Time + (Time_step_shelf/2) > restart_time)) then + if (BTEST(Restart_control,1)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) endif + if (BTEST(Restart_control,0)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) + endif + restart_time = restart_time + restint endif - enddo !!!!!!! end loop + ns = ns + 1 + call callTree_leave("Main loop") + enddo call cpu_clock_end(mainClock) call cpu_clock_begin(termClock) if (Restart_control>=0) then call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) - ! Write ocean solo restart file. + + ! Write ice shelf solo restart file. call open_file(unit, trim(dirs%restart_output_dir)//'shelf.res', nohdrs=.true.) if (is_root_pe())then write(unit, '(i6,8x,a)') calendar_type, & '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' - call get_date(Start_time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Model start time: year, month, day, hour, minute, second' - call get_date(Time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Current model time: year, month, day, hour, minute, second' - end if + endif call close_file(unit) endif @@ -402,11 +457,12 @@ program SHELF_main close(unit) endif - call diag_mediator_end(Time, ice_shelf_CSp%diag, end_diag_manager=.true.) + call callTree_waypoint("End Shelf_main") + call diag_mediator_end(Time, diag, end_diag_manager=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end call ice_shelf_end(ice_shelf_CSp) -end program SHELF_main +end program Shelf_main diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 deleted file mode 100644 index 64c4b4ce0a..0000000000 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ /dev/null @@ -1,338 +0,0 @@ -module user_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* Rewritten by Robert Hallberg, June 2009 * -!* * -!* This file contains the subroutines that a user should modify to * -!* to set the surface wind stresses and fluxes of buoyancy or * -!* temperature and fresh water. They are called when the run-time * -!* parameters WIND_CONFIG or BUOY_CONFIG are set to "USER". The * -!* standard version has simple examples, along with run-time error * -!* messages that will cause the model to abort if this code has not * -!* been modified. This code is intended for use with relatively * -!* simple specifications of the forcing. For more complicated forms, * -!* it is probably a good idea to read the forcing from input files * -!* using "file" for WIND_CONFIG and BUOY_CONFIG. * -!* * -!* USER_wind_forcing should set the surface wind stresses (taux and * -!* tauy) perhaps along with the surface friction velocity (ustar). * -!* * -!* USER_buoyancy forcing is used to set the surface buoyancy * -!* forcing, which may include a number of fresh water flux fields * -!* (evap, lprec, fprec, lrunoff, frunoff, and * -!* vprec) and the surface heat fluxes (sw, lw, latent and sens) * -!* if temperature and salinity are state variables, or it may simply * -!* be the buoyancy flux if it is not. This routine also has coded a * -!* restoring to surface values of temperature and salinity. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, param_file_type, log_version -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time -use MOM_tracer_flow_control, only : call_tracer_set_forcing -use MOM_tracer_flow_control, only : tracer_flow_control_CS -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface - -implicit none ; private - -public USER_wind_forcing, USER_buoyancy_forcing, USER_surface_forcing_init - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - -type, public :: user_surface_forcing_CS ; private - ! This control structure should be used to store any run-time variables - ! associated with the user-specified forcing. It can be readily modified - ! for a specific case, and because it is private there will be no changes - ! needed in other code (although they will have to be recompiled). - ! The variables in the cannonical example are used for some common - ! cases, but do not need to be used. - - logical :: use_temperature ! If true, temperature and salinity are used as - ! state variables. - logical :: restorebuoy ! If true, use restoring surface buoyancy forcing. - real :: Rho0 ! The density used in the Boussinesq approximation [R ~> kg m-3]. - real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. - real :: Flux_const ! The restoring rate at the surface [Z T-1 ~> m s-1]. - real :: gust_const ! A constant unresolved background gustiness - ! that contributes to ustar [R Z L T-1 ~> Pa]. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. -end type user_surface_forcing_CS - -contains - -!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [R Z L T-2 ~> Pa]. -!! These are the stresses in the direction of the model grid (i.e. the same -!! direction as the u- and v- velocities). -subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< The time of the fluxes - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to user_surface_forcing_init - -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy [R Z L T-2 ~> Pa]. -! In addition, this subroutine can be used to set the surface friction velocity, -! forces%ustar [Z T-1 ~> m s-1], which is needed with a bulk mixed layer. - - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_wind_surface_forcing: " // & - "User forcing routine called without modification." ) - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) - - ! Set the surface wind stresses [Pa]. A positive taux - ! accelerates the ocean to the (pseudo-)east. - - ! The i-loop extends to is-1 so that taux can be used later in the - ! calculation of ustar - otherwise the lower bound would be Isq. - do j=js,je ; do I=is-1,Ieq - ! Change this to the desired expression. - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - enddo ; enddo - do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. - enddo ; enddo - - ! Set the surface friction velocity [Z s-1 ~> m s-1]. ustar is always positive. - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) - enddo ; enddo ; endif - -end subroutine USER_wind_forcing - -!> This subroutine specifies the current surface fluxes of buoyancy or -!! temperature and fresh water. It may also be modified to add -!! surface fluxes of user provided tracers. -subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day !< The time of the fluxes - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to user_surface_forcing_init - -! This subroutine specifies the current surface fluxes of buoyancy or -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. - -! When temperature is used, there are long list of fluxes that need to be -! set - essentially the same as for a full coupled model, but most of these -! can be simply set to zero. The net fresh water flux should probably be -! set in fluxes%evap and fluxes%lprec, with any salinity restoring -! appearing in fluxes%vprec, and the other water flux components -! (fprec, lrunoff and frunoff) left as arrays full of zeros. -! Evap is usually negative and precip is usually positive. All heat fluxes -! are in W m-2 and positive for heat going into the ocean. All fresh water -! fluxes are in [R Z T-1 ~> kg m-2 s-1] and positive for water moving into the ocean. - - real :: Temp_restore ! The temperature that is being restored toward [C]. - real :: Salin_restore ! The salinity that is being restored toward [ppt] - real :: density_restore ! The potential density that is being restored toward [R ~> kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. - real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. - - integer :: i, j, is, ie, js, je - integer :: isd, ied, jsd, jed - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "User forcing routine called without modification." ) - - ! Allocate and zero out the forcing arrays, as necessary. This portion is - ! usually not changed. - if (CS%use_temperature) then - call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) - - call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) - else ! This is the buoyancy only mode. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - endif - - - ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. - - if ( CS%use_temperature ) then - ! Set whichever fluxes are to be used here. Any fluxes that - ! are always zero do not need to be changed here. - do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] - ! and are positive downward - i.e. evaporation should be negative. - fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) - fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) - - ! vprec will be set later, if it is needed for salinity restoring. - fluxes%vprec(i,j) = 0.0 - - ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. - fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%sw(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - else ! This is the buoyancy only mode. - do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean [L2 T-3 ~> m2 s-3]. A positive - ! buoyancy flux is of the same sign as heating the ocean. - fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "Temperature and salinity restoring used without modification." ) - - rhoXcp = CS%Rho0 * fluxes%C_p - do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in degC) and - ! salinity (in ppt or PSU) that are being restored toward. - Temp_restore = 0.0 - Salin_restore = 0.0 - - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & - (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) - enddo ; enddo - else - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "Buoyancy restoring used without modification." ) - - ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 - do j=js,je ; do i=is,ie - ! Set density_restore to an expression for the surface potential - ! density [R ~> kg m-3] that is being restored toward. - density_restore = 1030.0*US%kg_m3_to_R - - fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - sfc_state%sfc_density(i,j)) - enddo ; enddo - endif - endif ! end RESTOREBUOY - -end subroutine USER_buoyancy_forcing - -!> This subroutine initializes the USER_surface_forcing module -subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to - !! the control structure for this module - - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "user_surface_forcing" ! This module's name. - - if (associated(CS)) then - call MOM_error(WARNING, "USER_surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - CS%diag => diag - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) - - call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) - - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes to the relative "//& - "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) - endif - -end subroutine USER_surface_forcing_init - -end module user_surface_forcing diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index dfdfeff8ef..f180cd9717 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -66,6 +66,7 @@ program MOM_main use ensemble_manager_mod, only : ensemble_pelist_setup use mpp_mod, only : set_current_pelist => mpp_set_current_pelist use time_interp_external_mod, only : time_interp_external_init + use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart @@ -207,11 +208,10 @@ program MOM_main character(len=40) :: mod_name = "MOM_main (MOM_driver)" ! This module's name. integer :: ocean_nthreads = 1 - integer :: ncores_per_node = 36 logical :: use_hyper_thread = .false. - integer :: omp_get_num_threads,omp_get_thread_num,get_cpu_affinity,adder,base_cpu + integer :: omp_get_num_threads,omp_get_thread_num namelist /ocean_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds,& - ocean_nthreads, ncores_per_node, use_hyper_thread + ocean_nthreads, use_hyper_thread !===================================================================== @@ -252,20 +252,11 @@ program MOM_main endif endif +!$ call fms_affinity_init +!$ call fms_affinity_set('OCEAN', use_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) -!$ base_cpu = get_cpu_affinity() -!$OMP PARALLEL private(adder) -!$ if (use_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 -!$ else -!$ adder = ncores_per_node + omp_get_thread_num()/2 -!$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity (base_cpu + adder) -!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() +!$OMP PARALLEL +!$ write(6,*) "ocean_solo OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() !$ call flush(6) !$OMP END PARALLEL diff --git a/docs/Doxyfile_nortd b/docs/Doxyfile_nortd index e07ce4f0b6..76b66b9dd3 100644 --- a/docs/Doxyfile_nortd +++ b/docs/Doxyfile_nortd @@ -794,7 +794,9 @@ INPUT = ../src \ front_page.md \ ../config_src/solo_driver \ ../config_src/dynamic_symmetric - ../config_src/coupled_driver/ocean_model_MOM.F90 + ../config_src/external + ../config_src/coupled_driver + # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses diff --git a/docs/Doxyfile_rtd b/docs/Doxyfile_rtd index 652f46f076..7a74004d19 100644 --- a/docs/Doxyfile_rtd +++ b/docs/Doxyfile_rtd @@ -783,8 +783,8 @@ WARN_LOGFILE = doxygen.log INPUT = ../src \ ../config_src/solo_driver \ ../config_src/dynamic_symmetric \ - ../config_src/coupled_driver/coupler_util.F90 \ - ../config_src/coupled_driver/ocean_model_MOM.F90 + ../config_src/external \ + ../config_src/coupled_driver # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses diff --git a/pkg/MOM6_DA_hooks b/pkg/MOM6_DA_hooks deleted file mode 160000 index 6d8834ca8c..0000000000 --- a/pkg/MOM6_DA_hooks +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 6d8834ca8cf399f1a0d202239d72919907f6cd74 diff --git a/pkg/geoKdTree b/pkg/geoKdTree deleted file mode 160000 index a4670b9743..0000000000 --- a/pkg/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -Subproject commit a4670b9743c883d310d821eeac5b1f77f587b9d5 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index c4bf6ea7f0..f130c2977a 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -52,6 +52,7 @@ module MOM_ALE use regrid_consts, only : coordinateUnits, coordinateMode, state_dependent use regrid_edge_values, only : edge_values_implicit_h4 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation +use PLM_functions, only : PLM_extrapolate_slope, PLM_monotonized_slope, PLM_slope_wa use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation implicit none ; private @@ -110,8 +111,9 @@ module MOM_ALE public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar -public pressure_gradient_plm -public pressure_gradient_ppm +public ALE_PLM_edge_values +public TS_PLM_edge_values +public TS_PPM_edge_values public adjustGridForIntegrity public ALE_initRegridding public ALE_getCoordinate @@ -1006,12 +1008,9 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c end subroutine ALE_remap_scalar -!> Use plm reconstruction for pressure gradient (determine edge values) -!! By using a PLM (limited piecewise linear method) reconstruction, this -!! routine determines the edge values for the salinity and temperature -!! within each layer. These edge values are returned and are used to compute -!! the pressure gradient (by computing the densities). -subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PLM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure @@ -1029,12 +1028,31 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext logical, intent(in) :: bdry_extrap !< If true, use high-order boundary !! extrapolation within boundary cells + call ALE_PLM_edge_values( CS, G, GV, h, tv%S, bdry_extrap, S_t, S_b ) + call ALE_PLM_edge_values( CS, G, GV, h, tv%T, bdry_extrap, T_t, T_b ) + +end subroutine TS_PLM_edge_values + +!> Calculate edge values (top and bottom of layer) 3d scalar array. +!! Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) + type(ALE_CS), intent(in) :: CS !< module control structure + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Q !< 3d scalar array + logical, intent(in) :: bdry_extrap !< If true, use high-order boundary + !! extrapolation within boundary cells + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_t !< Scalar at the top edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_b !< Scalar at the bottom edge of each layer ! Local variables integer :: i, j, k - real :: hTmp(GV%ke) - real :: tmp(GV%ke) - real, dimension(CS%nk,2) :: ppol_E !Edge value of polynomial - real, dimension(CS%nk,2) :: ppol_coefs !Coefficients of polynomial + real :: slp(GV%ke) + real :: mslp real :: h_neglect if (.not.CS%answers_2018) then @@ -1045,48 +1063,40 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext h_neglect = GV%kg_m2_to_H*1.0e-30 endif - ! Determine reconstruction within each column - !$OMP parallel do default(shared) private(hTmp,ppol_E,ppol_coefs,tmp) + !$OMP parallel do default(shared) private(slp,mslp) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - ! Build current grid - hTmp(:) = h(i,j,:) - tmp(:) = tv%S(i,j,:) - ! Reconstruct salinity profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) & - call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - S_t(i,j,k) = ppol_E(k,1) - S_b(i,j,k) = ppol_E(k,2) + slp(1) = 0. + do k = 2, GV%ke-1 + slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1)) enddo + slp(GV%ke) = 0. - ! Reconstruct temperature profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - tmp(:) = tv%T(i,j,:) - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) & - call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - T_t(i,j,k) = ppol_E(k,1) - T_b(i,j,k) = ppol_E(k,2) + do k = 2, GV%ke-1 + mslp = PLM_monotonized_slope(Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1), slp(k-1), slp(k), slp(k+1)) + Q_t(i,j,k) = Q(i,j,k) - 0.5 * mslp + Q_b(i,j,k) = Q(i,j,k) + 0.5 * mslp enddo + if (bdry_extrap) then + mslp = - PLM_extrapolate_slope(h(i,j,2), h(i,j,1), h_neglect, Q(i,j,2), Q(i,j,1)) + Q_t(i,j,1) = Q(i,j,1) - 0.5 * mslp + Q_b(i,j,1) = Q(i,j,1) + 0.5 * mslp + mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, Q(i,j,GV%ke-1), Q(i,j,GV%ke)) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) - 0.5 * mslp + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + 0.5 * mslp + else + Q_t(i,j,1) = Q(i,j,1) + Q_b(i,j,1) = Q(i,j,1) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + endif enddo ; enddo -end subroutine pressure_gradient_plm - +end subroutine ALE_PLM_edge_values -!> Use ppm reconstruction for pressure gradient (determine edge values) -!> By using a PPM (limited piecewise linear method) reconstruction, this -!> routine determines the edge values for the salinity and temperature -!> within each layer. These edge values are returned and are used to compute -!> the pressure gradient (by computing the densities). -subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PPM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure @@ -1168,7 +1178,7 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext enddo ; enddo -end subroutine pressure_gradient_ppm +end subroutine TS_PPM_edge_values !> Initializes regridding for the main ALE algorithm diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 65cf5b9d55..71ba83f3ba 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -1027,11 +1027,11 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x end function average_value_ppoly !> Measure totals and bounds on source grid -subroutine measure_input_bounds( n0, h0, u0, ppoly_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) +subroutine measure_input_bounds( n0, h0, u0, edge_values, h0tot, h0err, u0tot, u0err, u0min, u0max ) integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid - real, dimension(n0,2), intent(in) :: ppoly_E !< Cell edge values on source grid + real, dimension(n0,2), intent(in) :: edge_values !< Cell edge values on source grid real, intent(out) :: h0tot !< Sum of cell widths real, intent(out) :: h0err !< Magnitude of round-off error in h0tot real, intent(out) :: u0tot !< Sum of cell widths times values @@ -1047,15 +1047,15 @@ subroutine measure_input_bounds( n0, h0, u0, ppoly_E, h0tot, h0err, u0tot, u0err h0err = 0. u0tot = h0(1) * u0(1) u0err = 0. - u0min = min( ppoly_E(1,1), ppoly_E(1,2) ) - u0max = max( ppoly_E(1,1), ppoly_E(1,2) ) + u0min = min( edge_values(1,1), edge_values(1,2) ) + u0max = max( edge_values(1,1), edge_values(1,2) ) do k = 2, n0 h0tot = h0tot + h0(k) h0err = h0err + eps * max(h0tot, h0(k)) u0tot = u0tot + h0(k) * u0(k) u0err = u0err + eps * max(abs(u0tot), abs(h0(k) * u0(k))) - u0min = min( u0min, ppoly_E(k,1), ppoly_E(k,2) ) - u0max = max( u0max, ppoly_E(k,1), ppoly_E(k,2) ) + u0min = min( u0min, edge_values(k,1), edge_values(k,2) ) + u0max = max( u0max, edge_values(k,1), edge_values(k,2) ) enddo end subroutine measure_input_bounds diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index f2c85d9872..d99c611229 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -24,11 +24,11 @@ module P1M_functions !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2018 ) +subroutine P1M_interpolation( N, h, u, edge_values, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] @@ -39,17 +39,17 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2 real :: u0_l, u0_r ! edge values (left and right) ! Bound edge values (routine found in 'edge_values.F90') - call bound_edge_values( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) ! Systematically average discontinuous edge values (routine found in ! 'edge_values.F90') - call average_discontinuous_edge_values( N, ppoly_E ) + call average_discontinuous_edge_values( N, edge_values ) ! Loop on interior cells to build interpolants do k = 1,N - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) ppoly_coef(k,1) = u0_l ppoly_coef(k,2) = u0_r - u0_l @@ -65,12 +65,12 @@ end subroutine P1M_interpolation !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) +subroutine P1M_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) ! Arguments integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] ! Local variables @@ -99,20 +99,20 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! by using the edge value in the neighboring cell. u0_r = u0 + 0.5 * slope - if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) < 0.0 ) then - slope = 2.0 * ( ppoly_E(2,1) - u0 ) + if ( (u1 - u0) * (edge_values(2,1) - u0_r) < 0.0 ) then + slope = 2.0 * ( edge_values(2,1) - u0 ) endif ! Using the limited slope, the left edge value is reevaluated and ! the interpolant coefficients recomputed if ( h0 /= 0.0 ) then - ppoly_E(1,1) = u0 - 0.5 * slope + edge_values(1,1) = u0 - 0.5 * slope else - ppoly_E(1,1) = u0 + edge_values(1,1) = u0 endif - ppoly_coef(1,1) = ppoly_E(1,1) - ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -127,18 +127,18 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_l = u1 - 0.5 * slope - if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) < 0.0 ) then - slope = 2.0 * ( u1 - ppoly_E(N-1,2) ) + if ( (u1 - u0) * (u0_l - edge_values(N-1,2)) < 0.0 ) then + slope = 2.0 * ( u1 - edge_values(N-1,2) ) endif if ( h1 /= 0.0 ) then - ppoly_E(N,2) = u1 + 0.5 * slope + edge_values(N,2) = u1 + 0.5 * slope else - ppoly_E(N,2) = u1 + edge_values(N,2) = u1 endif - ppoly_coef(N,1) = ppoly_E(N,1) - ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) end subroutine P1M_boundary_extrapolation diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 434668894b..e3a9f75a3c 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -25,11 +25,11 @@ module P3M_functions !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) +subroutine P3M_interpolation( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1]. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the @@ -41,7 +41,7 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, ! This routine could be called directly instead of having to call ! 'P3M_interpolation' first but we do that to provide an homogeneous ! interface. - call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) + call P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) end subroutine P3M_interpolation @@ -58,11 +58,11 @@ end subroutine P3M_interpolation !! c. If not, monotonize cubic curve and rebuild it !! !! Step 3 of the monotonization process leaves all edge values unchanged. -subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) +subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for @@ -86,10 +86,10 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer eps = 1e-10 ! 1. Bound edge values (boundary cells are assumed to be local extrema) - call bound_edge_values( N, h, u, ppoly_E, hNeglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, hNeglect, answers_2018 ) ! 2. Systematically average discontinuous edge values - call average_discontinuous_edge_values( N, ppoly_E ) + call average_discontinuous_edge_values( N, edge_values ) ! 3. Loop on cells and do the following @@ -99,8 +99,8 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer do k = 1,N ! Get edge values, edge slopes and cell width - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) u1_l = ppoly_S(k,1) u1_r = ppoly_S(k,2) @@ -151,7 +151,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer endif ! Build cubic interpolant (compute the coefficients) - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) ! Check whether cubic is monotonic monotonic = is_cubic_monotonic( ppoly_coef, k ) @@ -168,7 +168,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer ppoly_S(k,2) = u1_r ! Recompute coefficients of cubic - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) enddo ! loop on cells @@ -188,12 +188,12 @@ end subroutine P3M_limiter !! computing the parabola based on the cell average and the right edge value !! and slope. The resulting cubic is not necessarily monotonic and the slopes !! are subsequently modified to yield a monotonic cubic. -subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & +subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef, & h_neglect, h_neglect_edge ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the @@ -235,7 +235,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -253,13 +253,13 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & endif ! Store edge values and slope, build cubic and check monotonicity - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r ppoly_S(i0,1) = u1_l ppoly_S(i0,2) = u1_r ! Store edge values and slope, build cubic and check monotonicity - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i0 ) if ( .not.monotonic ) then @@ -268,7 +268,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! Rebuild cubic after monotonization ppoly_S(i0,1) = u1_l ppoly_S(i0,2) = u1_r - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) endif @@ -295,7 +295,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -313,12 +313,12 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & endif ! Store edge values and slope, build cubic and check monotonicity - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i1 ) if ( .not.monotonic ) then @@ -327,7 +327,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! Rebuild cubic after monotonization ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) endif @@ -340,10 +340,10 @@ end subroutine P3M_boundary_extrapolation !! !! NOTE: edge values and slopes MUST have been properly calculated prior to !! calling this routine. -subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) +subroutine build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) real, dimension(:), intent(in) :: h !< cell widths (size N) [H] integer, intent(in) :: k !< The index of the cell to work on - real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial in arbitrary units [A] + real, dimension(:,:), intent(in) :: edge_values !< Edge value of polynomial in arbitrary units [A] real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] @@ -355,8 +355,8 @@ subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) h_c = h(k) - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) u1_l = ppoly_S(k,1) * h_c u1_r = ppoly_S(k,2) * h_c diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index 135f53a8a1..6608e85eda 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -15,10 +15,10 @@ module PCM_functions !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) +subroutine PCM_reconstruction( N, u, edge_values, ppoly_coef ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: u !< cell averages - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial, !! with the same units as u. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, !! with the same units as u. @@ -32,7 +32,7 @@ subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) ! The edge values are equal to the cell average do k = 1,N - ppoly_E(k,:) = u(k) + edge_values(k,:) = u(k) enddo end subroutine PCM_reconstruction diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index ed82ad1e0b..da60f9614a 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -5,21 +5,189 @@ module PLM_functions implicit none ; private -public PLM_reconstruction, PLM_boundary_extrapolation +public PLM_boundary_extrapolation +public PLM_extrapolate_slope +public PLM_monotonized_slope +public PLM_reconstruction +public PLM_slope_wa +public PLM_slope_cw real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness contains +!> Returns a limited PLM slope following White and Adcroft, 2008. [units of u] +!! Note that this is not the same as the Colella and Woodward method. +real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [units of u] + real :: u_min, u_max ! Minimum and maximum value across cell [units of u] + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! Quasi-second order difference + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_wa = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_wa = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_wa) < u_min .or. u_c + 0.5*abs(PLM_slope_wa) > u_max) then + PLM_slope_wa = PLM_slope_wa * ( 1. - epsilon(PLM_slope_wa) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. + if (abs(PLM_slope_wa) < 1.E-140) PLM_slope_wa = 0. + +end function PLM_slope_wa + +!> Returns a limited PLM slope following Colella and Woodward 1984. +real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [units of u] + real :: u_min, u_max ! Minimum and maximum value across cell [units of u] + real :: h_cn ! Thickness of center cell [units of grid thickness] + + h_cn = h_c + h_neglect + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = ( h_c / ( h_cn + ( h_l + h_r ) ) ) * ( & + ( 2.*h_l + h_c ) / ( h_r + h_cn ) * sigma_r & + + ( 2.*h_r + h_c ) / ( h_l + h_cn ) * sigma_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_cw = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_cw = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_cw) < u_min .or. u_c + 0.5*abs(PLM_slope_cw) > u_max) then + PLM_slope_cw = PLM_slope_cw * ( 1. - epsilon(PLM_slope_cw) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. + if (abs(PLM_slope_cw) < 1.E-140) PLM_slope_cw = 0. + +end function PLM_slope_cw + +!> Returns a limited PLM slope following Colella and Woodward 1984. +real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + real, intent(in) :: s_l !< PLM slope of left cell [units of u] + real, intent(in) :: s_c !< PLM slope of center cell [units of u] + real, intent(in) :: s_r !< PLM slope of right cell [units of u] + ! Local variables + real :: e_r, e_l, edge ! Right, left and temporary edge values [units of u] + real :: almost_two ! The number 2, almost. + real :: slp ! Magnitude of PLM central slope [units of u] + + almost_two = 2. * ( 1. - epsilon(s_c) ) + + ! Edge values of neighbors abutting this cell + e_r = u_l + 0.5*s_l + e_l = u_r - 0.5*s_r + slp = abs(s_c) + + ! Check that left edge is between right edge of cell to the left and this cell mean + edge = u_c - 0.5 * s_c + if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then + edge = 0.5 * ( edge + e_r ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + ! Check that right edge is between left edge of cell to the right and this cell mean + edge = u_c + 0.5 * s_c + if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then + edge = 0.5 * ( edge + e_l ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + PLM_monotonized_slope = sign( slp, s_c ) + +end function PLM_monotonized_slope + +!> Returns a PLM slope using h2 extrapolation from a cell to the left. +!! Use the negative to extrapolate from the a cell to the right. +real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + ! Local variables + real :: left_edge ! Left edge value [units of u] + real :: hl, hc ! Left and central cell thicknesses [units of grid thickness] + + ! Avoid division by zero for vanished cells + hl = h_l + h_neglect + hc = h_c + h_neglect + + ! The h2 scheme is used to compute the left edge value + left_edge = (u_l*hc + u_c*hl) / (hl + hc) + + PLM_extrapolate_slope = 2.0 * ( u_c - left_edge ) + +end function PLM_extrapolate_slope + + !> Reconstruction by linear polynomials within each cell !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) +subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, !! with the same units as u. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly !! with the same units as u. @@ -31,149 +199,45 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) integer :: k ! loop index real :: u_l, u_c, u_r ! left, center and right cell averages real :: h_l, h_c, h_r, h_cn ! left, center and right cell widths - real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes real :: slope ! retained PLM slope real :: a, b ! auxiliary variables real :: u_min, u_max, e_l, e_r, edge - real :: almost_one, almost_two + real :: almost_one real, dimension(N) :: slp, mslp real :: hNeglect hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect almost_one = 1. - epsilon(slope) - almost_two = 2. * almost_one ! Loop on interior cells do k = 2,N-1 - - ! Get cell averages - u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - - ! Get cell widths - h_l = h(k-1) ; h_c = h(k) ; h_r = h(k+1) - h_cn = max( h_c, hNeglect ) ! To avoid division by zero - - ! Side differences - sigma_r = u_r - u_c - sigma_l = u_c - u_l - - ! This is the second order slope given by equation 1.7 of - ! Piecewise Parabolic Method, Colella and Woodward (1984), - ! http://dx.doi.org/10.1016/0021-991(84)90143-8. - ! For uniform resolution it simplifies to ( u_r - u_l )/2 . - ! sigma_c = ( h_c / ( h_cn + ( h_l + h_r ) ) ) * ( & - ! ( 2.*h_l + h_c ) / ( h_r + h_cn ) * sigma_r & - ! + ( 2.*h_r + h_c ) / ( h_l + h_cn ) * sigma_l ) - - ! This is the original estimate of the second order slope from Laurent - ! but multiplied by h_c - sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + hNeglect) ) - - if ( (sigma_l * sigma_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( u_l, u_c, u_r ) - u_max = max( u_l, u_c, u_r ) - slope = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - endif - - ! This block tests to see if roundoff causes edge values to be out of bounds - u_min = min( u_l, u_c, u_r ) - u_max = max( u_l, u_c, u_r ) - if (u_c - 0.5*abs(slope) < u_min .or. u_c + 0.5*abs(slope) > u_max) then - slope = slope * almost_one - endif - - ! An attempt to avoid inconsistency when the values become unrepresentable. - if (abs(slope) < 1.E-140) slope = 0. - - ! Safety check - this block really should not be needed ... -! if (u_c - 0.5*abs(slope) < u_min .or. u_c + 0.5*abs(slope) > u_max) then -! write(0,*) 'l,c,r=',u_l,u_c,u_r -! write(0,*) 'min,max=',u_min,u_max -! write(0,*) 'slp=',slope -! sigma_l = u_c-0.5*abs(slope) -! sigma_r = u_c+0.5*abs(slope) -! write(0,*) 'lo,hi=',sigma_l,sigma_r -! write(0,*) 'elo,ehi=',sigma_l-u_min,sigma_r-u_max -! stop 'Limiter failed!' -! endif - - slp(k) = slope - ppoly_E(k,1) = u_c - 0.5 * slope - ppoly_E(k,2) = u_c + 0.5 * slope - + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), hNeglect, u(k-1), u(k), u(k+1)) enddo ! end loop on interior cells - ! Boundary cells use PCM. Extrapolation is handled in a later routine. + ! Boundary cells use PCM. Extrapolation is handled after monotonization. slp(1) = 0. - ppoly_E(1,2) = u(1) slp(N) = 0. - ppoly_E(N,1) = u(N) ! This loop adjusts the slope so that edge values are monotonic. do K = 2, N-1 - u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - e_r = ppoly_E(k-1,2) ! Right edge from cell k-1 - e_l = ppoly_E(k+1,1) ! Left edge from cell k - mslp(k) = abs(slp(k)) - u_min = min(e_r, u_c) - u_max = max(e_r, u_c) - edge = u_c - 0.5 * slp(k) - if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then - edge = 0.5 * ( edge + e_r ) ! * almost_one? - mslp(k) = min( mslp(k), abs( edge - u_c ) * almost_two ) - endif - edge = u_c + 0.5 * slp(k) - if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then - edge = 0.5 * ( edge + e_l ) ! * almost_one? - mslp(k) = min( mslp(k), abs( edge - u_c ) * almost_two ) - endif + mslp(k) = PLM_monotonized_slope( u(k-1), u(k), u(k+1), slp(k-1), slp(k), slp(k+1) ) enddo ! end loop on interior cells mslp(1) = 0. mslp(N) = 0. - ! Check that the above adjustment worked -! do K = 2, N-1 -! u_r = u(k-1) + 0.5 * sign( mslp(k-1), slp(k-1) ) ! Right edge from cell k-1 -! u_l = u(k) - 0.5 * sign( mslp(k), slp(k) ) ! Left edge from cell k -! if ( (u(k)-u(k-1)) * (u_l-u_r) < 0. ) then -! stop 'Adjustment failed!' -! endif -! enddo ! end loop on interior cells - ! Store and return edge values and polynomial coefficients. - ppoly_E(1,1) = u(1) - ppoly_E(1,2) = u(1) + edge_values(1,1) = u(1) + edge_values(1,2) = u(1) ppoly_coef(1,1) = u(1) ppoly_coef(1,2) = 0. do k = 2, N-1 - slope = sign( mslp(k), slp(k) ) + slope = mslp(k) u_l = u(k) - 0.5 * slope ! Left edge value of cell k u_r = u(k) + 0.5 * slope ! Right edge value of cell k - ! Check that final edge values are bounded - u_min = min( u(k-1), u(k) ) - u_max = max( u(k-1), u(k) ) - if (u_lu_max) then - write(0,*) 'u(k-1)=',u(k-1),'u(k)=',u(k),'slp=',slp(k),'u_l=',u_l - stop 'Left edge out of bounds' - endif - u_min = min( u(k+1), u(k) ) - u_max = max( u(k+1), u(k) ) - if (u_ru_max) then - write(0,*) 'u(k)=',u(k),'u(k+1)=',u(k+1),'slp=',slp(k),'u_r=',u_r - stop 'Right edge out of bounds' - endif - - ppoly_E(k,1) = u_l - ppoly_E(k,2) = u_r + edge_values(k,1) = u_l + edge_values(k,2) = u_r ppoly_coef(k,1) = u_l ppoly_coef(k,2) = ( u_r - u_l ) ! Check to see if this evaluation of the polynomial at x=1 would be @@ -184,8 +248,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ppoly_coef(k,2) = ppoly_coef(k,2) * almost_one endif enddo - ppoly_E(N,1) = u(N) - ppoly_E(N,2) = u(N) + edge_values(N,1) = u(N) + edge_values(N,2) = u(N) ppoly_coef(N,1) = u(N) ppoly_coef(N,2) = 0. @@ -201,70 +265,40 @@ end subroutine PLM_reconstruction !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. - -subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) +subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, !! with the same units as u. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h - ! Local variables - real :: u0, u1 ! cell averages - real :: h0, h1 ! corresponding cell widths real :: slope ! retained PLM slope real :: hNeglect hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! ----------------------------------------- - ! Left edge value in the left boundary cell - ! ----------------------------------------- - h0 = h(1) + hNeglect - h1 = h(2) + hNeglect - - u0 = u(1) - u1 = u(2) - - ! The h2 scheme is used to compute the right edge value - ppoly_E(1,2) = (u0*h1 + u1*h0) / (h0 + h1) - - ! The standard PLM slope is computed as a first estimate for the - ! reconstruction within the cell - slope = 2.0 * ( ppoly_E(1,2) - u0 ) - - ppoly_E(1,1) = u0 - 0.5 * slope - ppoly_E(1,2) = u0 + 0.5 * slope - - ppoly_coef(1,1) = ppoly_E(1,1) - ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) - - ! ------------------------------------------ - ! Right edge value in the left boundary cell - ! ------------------------------------------ - h0 = h(N-1) + hNeglect - h1 = h(N) + hNeglect + ! Extrapolate from 2 to 1 to estimate slope + slope = - PLM_extrapolate_slope( h(2), h(1), hNeglect, u(2), u(1) ) - u0 = u(N-1) - u1 = u(N) + edge_values(1,1) = u(1) - 0.5 * slope + edge_values(1,2) = u(1) + 0.5 * slope - ! The h2 scheme is used to compute the right edge value - ppoly_E(N,1) = (u0*h1 + u1*h0) / (h0 + h1) + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) - ! The standard PLM slope is computed as a first estimate for the - ! reconstruction within the cell - slope = 2.0 * ( u1 - ppoly_E(N,1) ) + ! Extrapolate from N-1 to N to estimate slope + slope = PLM_extrapolate_slope( h(N-1), h(N), hNeglect, u(N-1), u(N) ) - ppoly_E(N,1) = u1 - 0.5 * slope - ppoly_E(N,2) = u1 + 0.5 * slope + edge_values(N,1) = u(N) - 0.5 * slope + edge_values(N,2) = u(N) + 0.5 * slope - ppoly_coef(N,1) = ppoly_E(N,1) - ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) end subroutine PLM_boundary_extrapolation diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 6d50703975..bbf93b4a81 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -25,11 +25,11 @@ module PPM_functions contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2018) +subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answers_2018) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths [H] real, dimension(N), intent(in) :: u !< Cell averages [A] - real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values [A] + real, dimension(N,2), intent(inout) :: edge_values !< Edge values [A] real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -39,13 +39,13 @@ subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_ real :: edge_l, edge_r ! Edge values (left and right) ! PPM limiter - call PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) ! Loop over all cells do k = 1,N - edge_l = ppoly_E(k,1) - edge_r = ppoly_E(k,2) + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) ! Store polynomial coefficients ppoly_coef(k,1) = edge_l @@ -59,11 +59,11 @@ end subroutine PPM_reconstruction !> Adjusts edge values using the standard PPM limiter (Colella & Woodward, JCP 1984) !! after first checking that the edge values are bounded by neighbors cell averages !! and that the edge values are monotonic between cell averages. -subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) +subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -74,10 +74,10 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) real :: expr1, expr2 ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) ! Make discontinuous edge values monotonic - call check_discontinuous_edge_values( N, u, ppoly_E ) + call check_discontinuous_edge_values( N, u, edge_values ) ! Loop on interior cells to apply the standard ! PPM limiter (Colella & Woodward, JCP 84) @@ -88,8 +88,8 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) u_c = u(k) u_r = u(k+1) - edge_l = ppoly_E(k,1) - edge_r = ppoly_E(k,2) + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) if ( (u_r - u_c)*(u_c - u_l) <= 0.0) then ! Flatten extremum @@ -116,21 +116,21 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) edge_r = u_c endif - ppoly_E(k,1) = edge_l - ppoly_E(k,2) = edge_r + edge_values(k,1) = edge_l + edge_values(k,2) = edge_r enddo ! end loop on interior cells ! PCM within boundary cells - ppoly_E(1,:) = u(1) - ppoly_E(N,:) = u(N) + edge_values(1,:) = u(1) + edge_values(N,:) = u(N) end subroutine PPM_limiter_standard !------------------------------------------------------------------------------ !> Reconstruction by parabolas within boundary cells -subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) +subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -148,7 +148,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! N: number of cells in grid ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials -! ppoly_E : edge values of piecewise polynomials +! edge_values : edge values of piecewise polynomials ! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells @@ -159,7 +159,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -199,7 +199,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -218,8 +218,8 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) u0_r = 3.0 * u0 - 2.0 * u0_l endif - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r a = u0_l b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r @@ -252,7 +252,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -271,8 +271,8 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) u0_r = 3.0 * u1 - 2.0 * u0_l endif - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r a = u0_l b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index a2adeb0c13..630ecb34fc 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -17,12 +17,12 @@ module PQM_functions !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) +subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -36,16 +36,16 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, real :: a, b, c, d, e ! parabola coefficients ! PQM limiter - call PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) + call PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_2018 ) ! Loop on cells to construct the cubic within each cell do k = 1,N - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) - u1_l = ppoly_S(k,1) - u1_r = ppoly_S(k,2) + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) h_c = h(k) @@ -72,12 +72,12 @@ end subroutine PQM_reconstruction !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) +subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Potentially modified edge slopes [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Potentially modified edge slopes [A H-1] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -102,10 +102,10 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E, hNeglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, hNeglect, answers_2018 ) ! Make discontinuous edge values monotonic (thru averaging) - call check_discontinuous_edge_values( N, u, ppoly_E ) + call check_discontinuous_edge_values( N, u, edge_values ) ! Loop on interior cells to apply the PQM limiter do k = 2,N-1 @@ -116,10 +116,10 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) inflexion_r = 0 ! Get edge values, edge slopes and cell width - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) - u1_l = ppoly_S(k,1) - u1_r = ppoly_S(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) ! Get cell widths and cell averages (boundary cells are assumed to ! be local extrema for the sake of slopes) @@ -320,19 +320,19 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) endif ! clause to check where to collapse inflexion points ! Save edge values and edge slopes for reconstruction - ppoly_E(k,1) = u0_l - ppoly_E(k,2) = u0_r - ppoly_S(k,1) = u1_l - ppoly_S(k,2) = u1_r + edge_values(k,1) = u0_l + edge_values(k,2) = u0_r + edge_slopes(k,1) = u1_l + edge_slopes(k,2) = u1_r enddo ! end loop on interior cells ! Constant reconstruction within boundary cells - ppoly_E(1,:) = u(1) - ppoly_S(1,:) = 0.0 + edge_values(1,:) = u(1) + edge_slopes(1,:) = 0.0 - ppoly_E(N,:) = u(N) - ppoly_S(N,:) = 0.0 + edge_values(N,:) = u(N) + edge_slopes(N,:) = 0.0 end subroutine PQM_limiter @@ -351,11 +351,11 @@ end subroutine PQM_limiter !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) +subroutine PQM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] ! Local variables integer :: i0, i1 @@ -389,7 +389,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -408,8 +408,8 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_r = 3.0 * u0 - 2.0 * u0_l endif - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r a = u0_l b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r @@ -447,7 +447,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -466,8 +466,8 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_r = 3.0 * u1 - 2.0 * u0_l endif - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r a = u0_l b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r @@ -498,12 +498,12 @@ end subroutine PQM_boundary_extrapolation !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) +subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -656,10 +656,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, endif ! Store edge values, edge slopes and coefficients - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r - ppoly_S(i0,1) = u1_l - ppoly_S(i0,2) = u1_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r + edge_slopes(i0,1) = u1_l + edge_slopes(i0,2) = u1_r a = u0_l b = h0 * u1_l @@ -809,10 +809,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, endif ! Store edge values, edge slopes and coefficients - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r - ppoly_S(i1,1) = u1_l - ppoly_S(i1,2) = u1_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r + edge_slopes(i1,1) = u1_l + edge_slopes(i1,2) = u1_r a = u0_l b = h1 * u1_l diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 5a1d151487..1ab225474c 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -349,13 +349,13 @@ end subroutine build_and_interpolate_grid !! !! It is assumed that the number of cells defining 'grid' and 'ppoly' are the !! same. -function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & +function get_polynomial_coordinate( N, h, x_g, edge_values, ppoly_coefs, & target_value, degree, answers_2018 ) result ( x_tgt ) ! Arguments integer, intent(in) :: N !< Number of grid cells real, dimension(N), intent(in) :: h !< Grid cell thicknesses [H] real, dimension(N+1), intent(in) :: x_g !< Grid interface locations [H] - real, dimension(N,2), intent(in) :: ppoly_E !< Edge values of interpolating polynomials [A] + real, dimension(N,2), intent(in) :: edge_values !< Edge values of interpolating polynomials [A] real, dimension(N,DEGREE_MAX+1), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials [A] real, intent(in) :: target_value !< Target value to find position for [A] integer, intent(in) :: degree !< Degree of the interpolating polynomials @@ -383,7 +383,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or ! largest value, depending on which bound is overtaken - if ( target_value <= ppoly_E(1,1) ) then + if ( target_value <= edge_values(1,1) ) then x_tgt = x_g(1) return ! return because there is no need to look further endif @@ -391,7 +391,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! Since discontinuous edge values are allowed, we check whether the target ! value lies between two discontinuous edge values at interior interfaces do k = 2,N - if ( ( target_value >= ppoly_E(k-1,2) ) .AND. ( target_value <= ppoly_E(k,1) ) ) then + if ( ( target_value >= edge_values(k-1,2) ) .AND. ( target_value <= edge_values(k,1) ) ) then x_tgt = x_g(k) return ! return because there is no need to look further endif @@ -400,7 +400,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or ! largest value, depending on which bound is overtaken - if ( target_value >= ppoly_E(N,2) ) then + if ( target_value >= edge_values(N,2) ) then x_tgt = x_g(N+1) return ! return because there is no need to look further endif @@ -411,7 +411,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! contains the target value. The variable k_found holds the index value ! of the cell where the taregt value lies. do k = 1,N - if ( ( target_value > ppoly_E(k,1) ) .AND. ( target_value < ppoly_E(k,2) ) ) then + if ( ( target_value > edge_values(k,1) ) .AND. ( target_value < edge_values(k,2) ) ) then k_found = k exit endif @@ -425,7 +425,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & if ( k_found == -1 ) then write(mesg,*) 'Could not find target coordinate', target_value, 'in get_polynomial_coordinate. This is '//& 'caused by an inconsistent interpolant (perhaps not monotonically increasing):', & - target_value, ppoly_E(1,1), ppoly_E(N,2) + target_value, edge_values(1,1), edge_values(N,2) call MOM_error( FATAL, mesg ) endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 15d8e5222d..95a6c090ce 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -259,6 +259,9 @@ module MOM !! calculated, and if it is 0, dtbt is calculated every step. type(time_type) :: dtbt_reset_interval !< A time_time representation of dtbt_reset_period. type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. + real :: update_OBC_period!< The time interval between OBC updates + type(time_type) :: update_OBC_interval !< A time_time representation of update_OBC_period. + type(time_type) :: update_OBC_time !< The next time OBC is applied. real, dimension(:,:,:), pointer :: & @@ -406,6 +409,7 @@ module MOM integer :: id_clock_ALE integer :: id_clock_other integer :: id_clock_offline_tracer +integer :: id_clock_unit_tests !>@} contains @@ -994,7 +998,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call enable_averages(dt_thermo, Time_local+real_to_time(US%T_to_s*(dt_thermo-dt)), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) call cpu_clock_end(id_clock_thick_diff) @@ -1020,7 +1024,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call disable_averaging(CS%diag) endif - if (CS%do_dynamics .and. CS%split) then !--------------------------- start SPLIT ! This section uses a split time stepping scheme for the dynamic equations, ! basically the stacked shallow water equations with viscosity. @@ -1034,6 +1037,17 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif endif + !OBC hack + if(associated(CS%OBC)) then + CS%OBC%update_OBC = .false. + if (CS%update_OBC_period == 0.0) CS%OBC%update_OBC = .true. + if (CS%update_OBC_period > 0.0) then + if (Time_local >= CS%update_OBC_time) then !### Change >= to > here. + CS%OBC%update_OBC = .true. + CS%update_OBC_time = CS%update_OBC_time + CS%update_OBC_interval + endif + endif + endif call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & @@ -1067,7 +1081,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) @@ -1479,7 +1493,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_depth_function(G, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) @@ -1505,7 +1519,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_depth_function(G, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) @@ -1720,7 +1734,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If True, exercises unit tests at model start up.", & default=.false., debuggingParam=.true.) if (do_unit_tests) then + id_clock_unit_tests = cpu_clock_id('(Ocean unit tests)', grain=CLOCK_MODULE) + call cpu_clock_begin(id_clock_unit_tests) call unit_tests(verbosity) + call cpu_clock_end(id_clock_unit_tests) endif call get_param(param_file, "MOM", "SPLIT", CS%split, & @@ -1878,6 +1895,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "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)) + !OBC hack + CS%update_OBC_period = -1.0 + call get_param(param_file, "MOM", "UPDATE_OBC_PERIOD", CS%update_OBC_period, & + "The period between recalculations OBC updates. "//& + "If DTBT_RESET_PERIOD is negative, DTBT is set based "//& + "only on information available at initialization. If 0, "//& + "OBC updates 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 ! This is here in case these values are used inappropriately. @@ -2286,7 +2312,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This subroutine calls user-specified tracer registration routines. ! Additional calls can be added to MOM_tracer_flow_control.F90. call call_tracer_register(dG%HI, GV, US, param_file, CS%tracer_flow_CSp, & - CS%tracer_Reg, restart_CSp) + CS%tracer_Reg, restart_CSp, CS%OBC) call MEKE_alloc_register_restart(dG%HI, param_file, CS%MEKE, restart_CSp) call set_visc_register_restarts(dG%HI, GV, param_file, CS%visc, restart_CSp) @@ -2537,7 +2563,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call VarMix_init(Time, G, GV, US, param_file, diag, CS%VarMix) call set_visc_init(Time, G, GV, US, param_file, diag, CS%visc, CS%set_visc_CSp, restart_CSp, CS%OBC) call thickness_diffuse_init(Time, G, GV, US, param_file, diag, CS%CDp, CS%thickness_diffuse_CSp) - if (CS%split) then allocate(eta(SZI_(G),SZJ_(G))) ; eta(:,:) = 0.0 call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & @@ -2558,6 +2583,19 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%dtbt_reset_time = CS%dtbt_reset_time - CS%dtbt_reset_interval endif endif + !OBC hack + if (associated(CS%OBC) .and. CS%update_OBC_period > 0.0) then + CS%update_OBC_interval = real_to_time(CS%update_OBC_period) + ! Set update_OBC_time to be the next even multiple of update_OBC_interval. + CS%update_OBC_time = Time_init + CS%update_OBC_interval * & + ((Time - Time_init) / CS%update_OBC_interval) + if ((CS%update_OBC_time > Time) .and. CS%OBC%update_OBC) then + ! Back up dtbt_reset_time one interval to force dtbt to be calculated, + ! because the restart was not aligned with the interval to recalculate + ! dtbt, and dtbt was not read from a restart file. + CS%update_OBC_time = CS%update_OBC_time - CS%update_OBC_interval + endif + endif elseif (CS%use_RK2) then call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, Time, G, GV, US, & param_file, diag, CS%dyn_unsplit_RK2_CSp, restart_CSp, & diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 2f96839ed5..cf274d32a9 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -74,6 +74,10 @@ module MOM_CoriolisAdv !>@{ Diagnostic IDs integer :: id_rv = -1, id_PV = -1, id_gKEu = -1, id_gKEv = -1 integer :: id_rvxu = -1, id_rvxv = -1 + ! integer :: id_hf_gKEu = -1, id_hf_gKEv = -1 + integer :: id_hf_gKEu_2d = -1, id_hf_gKEv_2d = -1 + ! integer :: id_hf_rvxu = -1, id_hf_rvxv = -1 + integer :: id_hf_rvxu_2d = -1, id_hf_rvxv_2d = -1 !>@} end type CoriolisAdv_CS @@ -211,6 +215,16 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) real :: QUHeff,QVHeff ! More temporary variables [H L2 T-1 s-1 ~> m3 s-2 or kg s-2]. integer :: i, j, k, n, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz +! Diagnostics for fractional thickness-weighted terms + real, allocatable, dimension(:,:) :: & + hf_gKEu_2d, hf_gKEv_2d, & ! Depth sum of hf_gKEu, hf_gKEv [L T-2 ~> m s-2]. + hf_rvxu_2d, hf_rvxv_2d ! Depth sum of hf_rvxu, hf_rvxv [L T-2 ~> m s-2]. + !real, allocatable, dimension(:,:,:) :: & + ! hf_gKEu, hf_gKEv, & ! accel. due to KE gradient x fract. thickness [L T-2 ~> m s-2]. + ! hf_rvxu, hf_rvxv ! accel. due to RV x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + ! To work, the following fields must be set outside of the usual ! is to ie range before this subroutine is called: ! v(is-1:ie+2,js-1:je+1), u(is-1:ie+1,js-1:je+2), h(is-1:ie+2,js-1:je+2), @@ -256,7 +270,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) enddo ; enddo !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,CS,AD,Area_h,Area_q,& - !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC) + !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC,eps_vel) do k=1,nz ! Here the second order accurate layer potential vorticities, q, @@ -828,6 +842,82 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) if (CS%id_gKEv>0) call post_data(CS%id_gKEv, AD%gradKEv, CS%diag) if (CS%id_rvxu > 0) call post_data(CS%id_rvxu, AD%rv_x_u, CS%diag) if (CS%id_rvxv > 0) call post_data(CS%id_rvxv, AD%rv_x_v, CS%diag) + + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_gKEu > 0) then + ! allocate(hf_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_gKEu(I,j,k) = AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_gKEu, hf_gKEu, CS%diag) + !endif + + !if (CS%id_hf_gKEv > 0) then + ! allocate(hf_gKEv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_gKEv(i,J,k) = AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_gKEv, hf_gKEv, CS%diag) + !endif + + if (CS%id_hf_gKEu_2d > 0) then + allocate(hf_gKEu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_gKEu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_gKEu_2d(I,j) = hf_gKEu_2d(I,j) + AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_gKEu_2d, hf_gKEu_2d, CS%diag) + deallocate(hf_gKEu_2d) + endif + + if (CS%id_hf_gKEv_2d > 0) then + allocate(hf_gKEv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_gKEv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_gKEv_2d(i,J) = hf_gKEv_2d(i,J) + AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_gKEv_2d, hf_gKEv_2d, CS%diag) + deallocate(hf_gKEv_2d) + endif + + !if (CS%id_hf_rvxv > 0) then + ! allocate(hf_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_rvxv(I,j,k) = AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_rvxv, hf_rvxv, CS%diag) + !endif + + !if (CS%id_hf_rvxu > 0) then + ! allocate(hf_rvxu(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_rvxu(i,J,k) = AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_rvxu, hf_rvxu, CS%diag) + !endif + + if (CS%id_hf_rvxv_2d > 0) then + allocate(hf_rvxv_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_rvxv_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_rvxv_2d(I,j) = hf_rvxv_2d(I,j) + AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_rvxv_2d, hf_rvxv_2d, CS%diag) + deallocate(hf_rvxv_2d) + endif + + if (CS%id_hf_rvxu_2d > 0) then + allocate(hf_rvxu_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_rvxu_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_rvxu_2d(i,J) = hf_rvxu_2d(i,J) + AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_rvxu_2d, hf_rvxu_2d, CS%diag) + deallocate(hf_rvxu_2d) + endif endif end subroutine CorAdCalc @@ -1087,6 +1177,70 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) 'Zonal Acceleration from Relative Vorticity', 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_rvxv > 0) call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + !CS%id_hf_gKEu = register_diag_field('ocean_model', 'hf_gKEu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_gKEu > 0) then + ! call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_gKEv = register_diag_field('ocean_model', 'hf_gKEv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_gKEv > 0) then + ! call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCuL, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_gKEu_2d > 0) then + call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCvL, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_gKEv_2d > 0) then + call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + + !CS%id_hf_rvxu = register_diag_field('ocean_model', 'hf_rvxu', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_rvxu > 0) then + ! call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + !CS%id_hf_rvxv = register_diag_field('ocean_model', 'hf_rvxv', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_rvxv > 0) then + ! call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCvL, Time, & + 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_rvxu_2d > 0) then + call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + + CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCuL, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_rvxv_2d > 0) then + call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + end subroutine CoriolisAdv_init !> Destructor for coriolisadv_cs diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 6902e13341..1963a8a773 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -7,9 +7,9 @@ module MOM_PressureForce use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_PressureForce_AFV, only : PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss -use MOM_PressureForce_AFV, only : PressureForce_AFV_init, PressureForce_AFV_end -use MOM_PressureForce_AFV, only : PressureForce_AFV_CS +use MOM_PressureForce_FV, only : PressureForce_FV_Bouss, PressureForce_FV_nonBouss +use MOM_PressureForce_FV, only : PressureForce_FV_init, PressureForce_FV_end +use MOM_PressureForce_FV, only : PressureForce_FV_CS use MOM_PressureForce_Mont, only : PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss use MOM_PressureForce_Mont, only : PressureForce_Mont_init, PressureForce_Mont_end use MOM_PressureForce_Mont, only : PressureForce_Mont_CS @@ -28,10 +28,8 @@ module MOM_PressureForce type, public :: PressureForce_CS ; private logical :: Analytic_FV_PGF !< If true, use the analytic finite volume form !! (Adcroft et al., Ocean Mod. 2008) of the PGF. - logical :: blocked_AFV !< If true, used the blocked version of the ANALYTIC_FV_PGF - !! code. The value of this parameter should not change answers. !> Control structure for the analytically integrated finite volume pressure force - type(PressureForce_AFV_CS), pointer :: PressureForce_AFV_CSp => NULL() + type(PressureForce_FV_CS), pointer :: PressureForce_FV_CSp => NULL() !> Control structure for the Montgomery potential form of pressure force type(PressureForce_Mont_CS), pointer :: PressureForce_Mont_CSp => NULL() end type PressureForce_CS @@ -64,10 +62,10 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e if (CS%Analytic_FV_PGF) then if (GV%Boussinesq) then - call PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & + call PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV_CSp, & ALE_CSp, p_atm, pbce, eta) else - call PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & + call PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV_CSp, & ALE_CSp, p_atm, pbce, eta) endif else @@ -111,8 +109,8 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) "described in Adcroft et al., O. Mod. (2008).", default=.true.) if (CS%Analytic_FV_PGF) then - call PressureForce_AFV_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_AFV_CSp, tides_CSp) + call PressureForce_FV_init(Time, G, GV, US, param_file, diag, & + CS%PressureForce_FV_CSp, tides_CSp) else call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, & CS%PressureForce_Mont_CSp, tides_CSp) @@ -125,7 +123,7 @@ subroutine PressureForce_end(CS) type(PressureForce_CS), pointer :: CS !< Pressure force control structure if (CS%Analytic_FV_PGF) then - call PressureForce_AFV_end(CS%PressureForce_AFV_CSp) + call PressureForce_FV_end(CS%PressureForce_FV_CSp) else call PressureForce_Mont_end(CS%PressureForce_Mont_CSp) endif diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_FV.F90 similarity index 87% rename from src/core/MOM_PressureForce_analytic_FV.F90 rename to src/core/MOM_PressureForce_FV.F90 index 59214dd914..6c01580e29 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -1,5 +1,5 @@ -!> Analytically integrated finite volume pressure gradient -module MOM_PressureForce_AFV +!> Finite volume pressure gradient (integrated by quadrature or analytically) +module MOM_PressureForce_FV ! This file is part of MOM6. See LICENSE.md for the license. @@ -14,18 +14,18 @@ module MOM_PressureForce_AFV use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_EOS, only : int_density_dz, int_specific_vol_dp -use MOM_EOS, only : int_density_dz_generic_plm, int_density_dz_generic_ppm -use MOM_EOS, only : int_spec_vol_dp_generic_plm -use MOM_EOS, only : int_density_dz_generic, int_spec_vol_dp_generic -use MOM_ALE, only : pressure_gradient_plm, pressure_gradient_ppm, ALE_CS +use MOM_density_integrals, only : int_density_dz, int_specific_vol_dp +use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm +use MOM_density_integrals, only : int_spec_vol_dp_generic_plm +use MOM_density_integrals, only : int_density_dz_generic_pcm, int_spec_vol_dp_generic_pcm +use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS implicit none ; private #include -public PressureForce_AFV, PressureForce_AFV_init, PressureForce_AFV_end -public PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss +public PressureForce_FV_init, PressureForce_FV_end +public PressureForce_FV_Bouss, PressureForce_FV_nonBouss ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -33,7 +33,7 @@ module MOM_PressureForce_AFV ! vary with the Boussinesq approximation, the Boussinesq variant is given first. !> Finite volume pressure gradient control structure -type, public :: PressureForce_AFV_CS ; private +type, public :: PressureForce_FV_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq !! approximation [R ~> kg m-3]. @@ -54,42 +54,15 @@ module MOM_PressureForce_AFV integer :: Recon_Scheme !< Order of the polynomial of the reconstruction of T & S !! for the finite volume pressure gradient calculation. !! By the default (1) is for a piecewise linear method - + real :: Stanley_T2_det_coeff !< The coefficient correlating SGS temperature variance with + !! the mean temperature gradient in the deterministic part of + !! the Stanley form of the Brankart correction. integer :: id_e_tidal = -1 !< Diagnostic identifier type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure -end type PressureForce_AFV_CS +end type PressureForce_FV_CS contains -!> Thin interface between the model and the Boussinesq and non-Boussinesq -!! pressure force routines. -subroutine PressureForce_AFV(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure - type(ALE_CS), pointer :: ALE_CSp !< ALE control structure - real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies - !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal - !! contributions or compressibility compensation. - - if (GV%Boussinesq) then - call PressureForce_AFV_bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - else - call PressureForce_AFV_nonbouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - endif - -end subroutine PressureForce_AFV - !> \brief Non-Boussinesq analytically-integrated finite volume form of pressure gradient !! !! Determines the acceleration due to hydrostatic pressure forces, using @@ -99,7 +72,7 @@ end subroutine PressureForce_AFV !! To work, the following fields must be set outside of the usual (is:ie,js:je) !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). -subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -107,7 +80,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. @@ -186,7 +159,10 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) if (.not.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") + "MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.") + if (CS%Stanley_T2_det_coeff>=0.) call MOM_error(FATAL, & + "MOM_PressureForce_FV_nonBouss: The Stanley parameterization is not yet"//& + "implemented in non-Boussinesq mode.") use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -251,9 +227,9 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p ! of freedeom needed to know the linear profile). if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) elseif ( CS%Recon_Scheme == 2) then - call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif @@ -266,10 +242,10 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p if ( CS%Recon_Scheme == 1 ) then call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), S_t(:,:,k), S_b(:,:,k), & p(:,:,K), p(:,:,K+1), alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & - tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & + tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & useMassWghtInterp=CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call MOM_error(FATAL, "PressureForce_AFV_nonBouss: "//& + call MOM_error(FATAL, "PressureForce_FV_nonBouss: "//& "int_spec_vol_dp_generic_ppm does not exist yet.") ! call int_spec_vol_dp_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & ! tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & @@ -279,7 +255,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p else call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & - dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & + US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & useMassWghtInterp=CS%useMassWghtInterp) endif @@ -426,7 +402,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) -end subroutine PressureForce_AFV_nonBouss +end subroutine PressureForce_FV_nonBouss !> \brief Boussinesq analytically-integrated finite volume form of pressure gradient !! @@ -436,7 +412,7 @@ end subroutine PressureForce_AFV_nonBouss !! To work, the following fields must be set outside of the usual (is:ie,js:je) !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). -subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -444,7 +420,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. @@ -503,7 +479,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - + real :: dTdi2, dTdj2 ! Differences in T variance [degC2] real, parameter :: C1_6 = 1.0/6.0 integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -515,7 +491,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) if (.not.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") + "MOM_PressureForce_FV_Bouss: Module must be initialized before it is used.") use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -524,6 +500,21 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at use_ALE = .false. if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS + if (CS%Stanley_T2_det_coeff>=0.) then + if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) + do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + ! SGS variance in i-direction [degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( tv%T(i+1,j,k) - tv%T(i,j,k) ) & + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( tv%T(i,j,k) - tv%T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( tv%T(i,j+1,k) - tv%T(i,j,k) ) & + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( tv%T(i,j,k) - tv%T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 + tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + enddo ; enddo ; enddo + endif + h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = 1.0 / GV%Rho0 @@ -628,9 +619,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! of freedeom needed to know the linear profile). if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) elseif ( CS%Recon_Scheme == 2 ) then - call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif @@ -669,19 +660,19 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! where the layers are located. if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call int_density_dz_generic_plm( T_t(:,:,k), T_b(:,:,k), S_t(:,:,k), S_b(:,:,k),& - e(:,:,K), e(:,:,K+1), rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, tv%eqn_of_state, dpa, intz_dpa, intx_dpa, inty_dpa, & + call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp=CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & - tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, dpa, & - intz_dpa, intx_dpa, inty_dpa) + call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + useMassWghtInterp=CS%useMassWghtInterp) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, dpa, & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa, & intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp) endif !$OMP parallel do default(shared) @@ -768,17 +759,17 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) -end subroutine PressureForce_AFV_Bouss +end subroutine PressureForce_FV_Bouss !> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure type(tidal_forcing_CS), optional, pointer :: tides_CSp !< Tides control structure ! This include declares and sets the variable "version". # include "version_variable.h" @@ -796,7 +787,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C if (associated(tides_CSp)) CS%tides_CSp => tides_CSp endif - mdl = "MOM_PressureForce_AFV" + mdl = "MOM_PressureForce_FV" 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 "//& @@ -811,7 +802,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C "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 "//& - "integrals near the bathymetry in AFV pressure gradient "//& + "integrals near the bathymetry in FV 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 "//& @@ -830,7 +821,11 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C "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.) - + call get_param(param_file, mdl, "PGF_STANLEY_T2_DET_COEFF", CS%Stanley_T2_det_coeff, & + "The coefficient correlating SGS temperature variance with "// & + "the mean temperature gradient in the deterministic part of "// & + "the Stanley form of the Brankart correction. "// & + "Negative values disable the scheme.", units="nondim", default=-1.0) if (CS%tides) then CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) @@ -841,20 +836,21 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale) -end subroutine PressureForce_AFV_init +end subroutine PressureForce_FV_init !> Deallocates the finite volume pressure gradient control structure -subroutine PressureForce_AFV_end(CS) - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume pressure control structure that +subroutine PressureForce_FV_end(CS) + type(PressureForce_FV_CS), pointer :: CS !< Finite volume pressure control structure that !! will be deallocated in this subroutine. if (associated(CS)) deallocate(CS) -end subroutine PressureForce_AFV_end +end subroutine PressureForce_FV_end -!> \namespace mom_pressureforce_afv +!> \namespace mom_pressureforce_fv !! !! Provides the Boussinesq and non-Boussinesq forms of horizontal accelerations -!! due to pressure gradients using a 2nd-order analytically vertically integrated -!! finite volume form, as described by Adcroft et al., 2008. +!! due to pressure gradients using a vertically integrated finite volume form, +!! as described by Adcroft et al., 2008. Integration in the vertical is made +!! either by quadrature or analytically. !! !! This form eliminates the thermobaric instabilities that had been a problem with !! previous forms of the pressure gradient force calculation, as described by @@ -868,4 +864,4 @@ end subroutine PressureForce_AFV_end !! ocean models. Ocean Modelling, 8, 279-300. !! http://dx.doi.org/10.1016/j.ocemod.2004.01.001 -end module MOM_PressureForce_AFV +end module MOM_PressureForce_FV diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 99268460df..cade4e074d 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -3,6 +3,7 @@ module MOM_PressureForce_Mont ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_density_integrals, only : int_specific_vol_dp use MOM_diag_mediator, only : post_data, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe @@ -13,7 +14,7 @@ module MOM_PressureForce_Mont use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_EOS, only : int_specific_vol_dp, query_compressible +use MOM_EOS, only : query_compressible implicit none ; private @@ -188,7 +189,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), & - 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1) + 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=1) enddo !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 @@ -506,7 +507,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! This no longer includes any pressure dependency, since this routine ! will come down with a fatal error if there is any compressibility. !$OMP parallel do default(shared) - do k=1,nz+1 ; do j=Jsq,Jeq+1 + do k=1,nz ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), & tv%eqn_of_state, EOSdom) do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 50ad121b77..de72fdbdfc 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -27,6 +27,7 @@ module MOM_barotropic use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type use MOM_verticalGrid, only : verticalGrid_type +use MOM_variables, only : accel_diag_ptrs implicit none ; private @@ -108,9 +109,6 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: lin_drag_u !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-1 ~> m s-1 or kg m-2 s-1]. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt_IC - !< The barotropic solvers estimate of the zonal transport as the initial condition for - !! the next call to btstep [H L2 T-1 ~> m3 s-1 or kg s-1]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: ubt_IC !< The barotropic solvers estimate of the zonal velocity that will be the initial !! condition for the next call to btstep [L T-1 ~> m s-1]. @@ -121,9 +119,6 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: lin_drag_v !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-1 ~> m s-1 or kg m-2 s-1]. - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt_IC - !< The barotropic solvers estimate of the zonal transport as the initial condition for - !! the next call to btstep [H L2 T-1 ~> m3 s-1 or kg s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vbt_IC !< The barotropic solvers estimate of the zonal velocity that will be the initial !! condition for the next call to btstep [L T-1 ~> m s-1]. @@ -192,6 +187,11 @@ module MOM_barotropic !! otherwise the Arakawa & Hsu scheme is used. If !! the deformation radius is not resolved Sadourny's !! scheme should probably be used. + logical :: integral_bt_cont !< If true, use the time-integrated velocity over the barotropic steps + !! to determine the integrated transports used to update the continuity + !! equation. Otherwise the transports are the sum of the transports + !! based on ]a series of instantaneous velocities and the BT_CONT_TYPE + !! for transports. This is only valid if a BT_CONT_TYPE is used. logical :: Nonlinear_continuity !< If true, the barotropic continuity equation !! uses the full ocean thickness for transport. integer :: Nonlin_cont_update_period !< The number of barotropic time steps @@ -258,9 +258,8 @@ module MOM_barotropic !! times the time-derivatives of thicknesses. The !! default is 0.1, and there will probably be real !! problems if this were set close to 1. - logical :: BT_cont_bounds !< If true, use the BT_cont_type variables to set - !! limits on the magnitude of the corrective mass - !! fluxes. + logical :: BT_cont_bounds !< If true, use the BT_cont_type variables to set limits + !! on the magnitude of the corrective mass fluxes. logical :: visc_rem_u_uh0 !< If true, use the viscous remnants when estimating !! the barotropic velocities that were used to !! calculate uh0 and vh0. False is probably the @@ -313,6 +312,7 @@ module MOM_barotropic integer :: id_BTC_ubt_EE = -1, id_BTC_ubt_WW = -1 integer :: id_BTC_FA_v_NN = -1, id_BTC_FA_v_N0 = -1, id_BTC_FA_v_S0 = -1, id_BTC_FA_v_SS = -1 integer :: id_BTC_vbt_NN = -1, id_BTC_vbt_SS = -1 + integer :: id_BTC_FA_u_rat0 = -1, id_BTC_FA_v_rat0 = -1, id_BTC_FA_h_rat0 = -1 integer :: id_uhbt0 = -1, id_vhbt0 = -1 !>@} @@ -328,14 +328,20 @@ module MOM_barotropic !! drawing from nearby to the west [H L ~> m2 or kg m-1]. real :: FA_u_WW !< The effective open face area for zonal barotropic transport !! drawing from locations far to the west [H L ~> m2 or kg m-1]. - real :: uBT_WW !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: uBT_WW !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_u_WW. uBT_WW must be non-negative. - real :: uBT_EE !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: uBT_EE !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_u_EE. uBT_EE must be non-positive. - real :: uh_crvW !< The curvature of face area with velocity for flow from the west [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: uh_WW !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: uh_EE !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: uh_crvW !< The curvature of face area with velocity for flow from the west [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_WW !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: uh_EE !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. end type local_BT_cont_u_type !> A desciption of the functional dependence of transport at a v-point @@ -348,14 +354,20 @@ module MOM_barotropic !! drawing from nearby to the south [H L ~> m2 or kg m-1]. real :: FA_v_SS !< The effective open face area for meridional barotropic transport !! drawing from locations far to the south [H L ~> m2 or kg m-1]. - real :: vBT_SS !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: vBT_SS !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_v_SS. vBT_SS must be non-negative. - real :: vBT_NN !< vBT_NN is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: vBT_NN !< vBT_NN is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_v_NN. vBT_NN must be non-positive. - real :: vh_crvS !< The curvature of face area with velocity for flow from the south [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: vh_crvN !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: vh_SS !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: vh_NN !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vh_crvS !< The curvature of face area with velocity for flow from the south [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_crvN !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_SS !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: vh_NN !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. end type local_BT_cont_v_type !> A container for passing around active tracer point memory limits @@ -394,7 +406,7 @@ module MOM_barotropic subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, & eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, & eta_out, uhbtav, vhbtav, G, GV, US, CS, & - visc_rem_u, visc_rem_v, etaav, OBC, BT_cont, eta_PF_start, & + visc_rem_u, visc_rem_v, etaav, ADp, OBC, BT_cont, eta_PF_start, & taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -447,6 +459,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: etaav !< The free surface height or column mass !! averaged over the barotropic integration [H ~> m or kg m-2]. + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers type(ocean_OBC_type), optional, pointer :: OBC !< The open boundary condition structure. type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic @@ -486,6 +499,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. vbt_dt ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & + tmp_h, & ! A temporary array at h points. e_anom ! The anomaly in the sea surface height or column mass ! averaged between the beginning and end of the time step, ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. @@ -509,7 +523,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ubt_old, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1]. ubt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. ubt_sum, & ! The sum of ubt over the time steps [L T-1 ~> m s-1]. + ubt_int, & ! The running time integral of ubt over the time steps [L ~> m]. uhbt_sum, & ! The sum of uhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3]. ubt_wtd, & ! A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1]. ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1]. azon, bzon, & ! _zon & _mer are the values of the Coriolis force which @@ -542,7 +558,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_old, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1]. vbt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. vbt_sum, & ! The sum of vbt over the time steps [L T-1 ~> m s-1]. + vbt_int, & ! The running time integral of vbt over the time steps [L ~> m]. vhbt_sum, & ! The sum of vhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3]. vbt_wtd, & ! A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1]. vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1]. Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2]. @@ -567,6 +585,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZIW_(CS),SZJW_(CS)) :: & eta_sum, & ! eta summed across the timesteps [H ~> m or kg m-2]. eta_wtd, & ! A weighted estimate used to calculate eta_out [H ~> m or kg m-2]. + eta_IC, & ! A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2] eta_PF, & ! A local copy of the 2-D eta field (either SSH anomaly or ! column mass anomaly) that was used to calculate the input ! pressure gradient accelerations [H ~> m or kg m-2]. @@ -592,11 +611,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! End of wide-sized variables. real, dimension(SZIBW_(CS),SZJW_(CS)) :: & - ubt_prev, uhbt_prev, ubt_sum_prev, uhbt_sum_prev, ubt_wtd_prev ! for OBC + ubt_prev, ubt_sum_prev, ubt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + uhbt_prev, uhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + uhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] real, dimension(SZIW_(CS),SZJBW_(CS)) :: & - vbt_prev, vhbt_prev, vbt_sum_prev, vhbt_sum_prev, vbt_wtd_prev ! for OBC - - real :: mass_to_Z ! The depth unit converison divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. + vbt_prev, vbt_sum_prev, vbt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + vhbt_prev, vhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + vhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] + real :: mass_to_Z ! The depth unit conversion divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. real :: mass_accel_to_Z ! The inverse of the mean density (Rho0) [R-1 ~> m3 kg-1]. real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim. real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. @@ -612,9 +636,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: dgeo_de ! The constant of proportionality between geopotential and ! sea surface height. It is a nondimensional number of ! order 1. For stability, this may be made larger - ! than physical problem would suggest. - real :: Instep ! The inverse of the number of barotropic time steps - ! to take. + ! than the physical problem would suggest. + real :: Instep ! The inverse of the number of barotropic time steps to take. real :: wt_end ! The weighting of the final value of eta_PF [nondim] integer :: nstep ! The number of barotropic time steps to take. type(time_type) :: & @@ -626,6 +649,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! velocity point [H ~> m or kg m-2] logical :: do_hifreq_output ! If true, output occurs every barotropic step. logical :: use_BT_cont, do_ave, find_etaav, find_PF, find_Cor + logical :: integral_BT_cont ! If true, update the barotropic continuity equation directly + ! from the initial condition using the time-integrated barotropic velocity. logical :: ice_is_rigid, nonblock_setup, interp_eta_PF logical :: project_velocity, add_uh0 @@ -639,17 +664,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: H_eff_dx2 ! The effective total thickness divided by the grid spacing ! squared [H L-2 ~> m-1 or kg m-4]. real :: u_max_cor, v_max_cor ! The maximum corrective velocities [L T-1 ~> m s-1]. + real :: uint_cor, vint_cor ! The maximum time-integrated corrective velocities [L ~> m]. real :: Htot ! The total thickness [H ~> m or kg m-2]. real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2]. real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] real, allocatable, dimension(:) :: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2 real :: sum_wt_vel, sum_wt_eta, sum_wt_accel, sum_wt_trans real :: I_sum_wt_vel, I_sum_wt_eta, I_sum_wt_accel, I_sum_wt_trans real :: dt_filt ! The half-width of the barotropic filter [T ~> s]. - real :: trans_wt1, trans_wt2 ! weight used to compute ubt_trans and vbt_trans + real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans integer :: nfilter logical :: apply_OBCs, apply_OBC_flather, apply_OBC_open @@ -662,6 +689,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, integer :: is, ie, js, je, nz, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: ioff, joff + integer :: l_seg if (.not.associated(CS)) call MOM_error(FATAL, & "btstep: Module MOM_barotropic must be initialized before it is used.") @@ -678,6 +706,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, use_BT_cont = .false. if (present(BT_cont)) use_BT_cont = (associated(BT_cont)) + integral_BT_cont = use_BT_cont .and. CS%integral_BT_cont interp_eta_PF = .false. if (present(eta_PF_start)) interp_eta_PF = (associated(eta_PF_start)) @@ -741,6 +770,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set the actual barotropic time step. Instep = 1.0 / real(nstep) dtbt = dt * Instep + Idtbt = 1.0 / dtbt bebt = CS%bebt be_proj = CS%bebt mass_accel_to_Z = 1.0 / GV%Rho0 @@ -784,6 +814,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, else call create_group_pass(CS%pass_eta_bt_rem, eta_PF, CS%BT_Domain) endif + if (integral_BT_cont) & + call create_group_pass(CS%pass_eta_bt_rem, eta_IC, CS%BT_Domain) call create_group_pass(CS%pass_eta_bt_rem, eta_src, CS%BT_Domain) ! The following halo updates are not needed without wide halos. RWH ! We do need them after all. @@ -804,6 +836,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif call create_group_pass(CS%pass_eta_ubt, eta, CS%BT_Domain) call create_group_pass(CS%pass_eta_ubt, ubt, vbt, CS%BT_Domain) + if (integral_BT_cont) then + call create_group_pass(CS%pass_eta_ubt, ubt_int, vbt_int, CS%BT_Domain) + ! This is only needed with integral_BT_cont, OBCs and multiple barotropic steps between halo updates. + if (apply_OBC_open) & + call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) + endif call create_group_pass(CS%pass_ubt_Cor, ubt_Cor, vbt_Cor, G%Domain) ! These passes occur at the end of the routine, as data is being readied to @@ -897,6 +935,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (interp_eta_PF) then eta_PF_1(i,j) = 0.0 ; d_eta_PF(i,j) = 0.0 endif + if (integral_BT_cont) then + eta_IC(i,j) = 0.0 + endif p_surf_dyn(i,j) = 0.0 if (CS%dynamic_psurf) dyn_coef_eta(i,j) = 0.0 enddo ; enddo @@ -911,7 +952,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP parallel do default(shared) do J=CS%jsdw-1,CS%jedw ; do i=CS%isdw,CS%iedw Cor_ref_v(i,J) = 0.0 ; BT_force_v(i,J) = 0.0 ; vbt(i,J) = 0.0 - Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(I,j) = 0.0 + Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0 enddo ; enddo ! Copy input arrays into their wide-halo counterparts. @@ -929,6 +970,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, eta_PF(i,j) = eta_PF_in(i,j) enddo ; enddo endif + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=G%jsd,G%jed ; do i=G%isd,G%ied + eta_IC(i,j) = eta_in(i,j) + enddo ; enddo + endif !$OMP parallel do default(shared) private(visc_rem) do k=1,nz ; do j=js,je ; do I=is-1,ie @@ -1001,7 +1048,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Calculate the open areas at the velocity points. ! The halo updates are needed before Datu is first used, either in set_up_BT_OBC or ubt_Cor. - if (use_BT_cont) then + if (integral_BT_cont) then + call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie, dt_baroclinic=dt) + elseif (use_BT_cont) then call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie) else if (CS%Nonlinear_continuity) then @@ -1014,7 +1063,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set up fields related to the open boundary conditions. if (apply_OBCs) then call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - Datu, Datv, BTCL_u, BTCL_v) + integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) endif ! Determine the difference between the sum of the layer fluxes and the @@ -1047,29 +1096,43 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt(i,J) = vbt(i,J) + CS%frhatv(i,J,k) * v_vh0(i,J,k) enddo ; enddo ; enddo endif - if (use_BT_cont) then - if (CS%adjust_BT_cont) then - ! Use the additional input transports to broaden the fits - ! over which the bt_cont_type applies. - - ! Fill in the halo data for ubt, vbt, uhbt, and vhbt. - if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) - if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) - call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie) - call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie) - if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) - if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) - + if ((use_BT_cont .or. integral_BT_cont) .and. CS%adjust_BT_cont) then + ! Use the additional input transports to broaden the fits + ! over which the bt_cont_type applies. + + ! Fill in the halo data for ubt, vbt, uhbt, and vhbt. + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie) + call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie) + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + + if (integral_BT_cont) then call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, 1+ievf-ie) + G, US, MS, halo=1+ievf-ie, dt_baroclinic=dt) + else + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, halo=1+ievf-ie) endif + endif + if (integral_BT_cont) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) = uhbt(I,j) - find_uhbt(dt*ubt(I,j), BTCL_u(I,j)) * Idt enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) = vhbt(i,J) - find_vhbt(dt*vbt(i,J), BTCL_v(i,J)) * Idt + enddo ; enddo + elseif (use_BT_cont) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J)) enddo ; enddo else !$OMP parallel do default(shared) @@ -1096,14 +1159,27 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ! Calculate the initial barotropic velocities from the layer's velocities. - !$OMP parallel do default(shared) - do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 - ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 - enddo ; enddo - !$OMP parallel do default(shared) - do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 - vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 - enddo ; enddo + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + enddo ; enddo + endif !$OMP parallel do default(shared) do j=js,je ; do k=1,nz ; do I=is-1,ie ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * U_in(I,j,k) @@ -1142,8 +1218,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then CS%IDatu(I,j) = 0.0 + elseif (integral_BT_cont) then + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & + CS%dy_Cu(I,j)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j), US), & + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) else CS%IDatu(I,j) = 1.0 / Htot_avg @@ -1165,8 +1244,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then CS%IDatv(i,J) = 0.0 + elseif (integral_BT_cont) then + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & + CS%dx_Cv(i,J)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J), US), & + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) else CS%IDatv(i,J) = 1.0 / Htot_avg @@ -1328,15 +1410,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) -!$OMP parallel default(none) shared(is,ie,js,je,nz,av_rem_u,av_rem_v,CS,visc_rem_u, & -!$OMP visc_rem_v,bt_rem_u,G,GV,nstep,bt_rem_v,Instep, & -!$OMP find_etaav,jsvf,jevf,isvf,ievf,eta_sum,eta_wtd, & -!$OMP ubt_sum,uhbt_sum,PFu_bt_sum,Coru_bt_sum,ubt_wtd,& -!$OMP ubt_trans,vbt_sum,vhbt_sum,PFv_bt_sum, & -!$OMP Corv_bt_sum,vbt_wtd,vbt_trans,eta_src,dt,dtbt, & -!$OMP Rayleigh_u, Rayleigh_v, & -!$OMP use_BT_Cont,BTCL_u,uhbt0,BTCL_v,vhbt0,eta,Idt,US) & -!$OMP private(u_max_cor,v_max_cor,eta_cor_max,Htot) + !$OMP parallel default(shared) private(u_max_cor,uint_cor,v_max_cor,vint_cor,eta_cor_max,Htot) !$OMP do do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo !$OMP do @@ -1406,7 +1480,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 eta_wtd(i,j) = 0.0 enddo ; enddo - endif + endif !$OMP do do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf ubt_sum(I,j) = 0.0 ; uhbt_sum(I,j) = 0.0 @@ -1417,29 +1491,37 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 vbt_sum(i,J) = 0.0 ; vhbt_sum(i,J) = 0.0 PFv_bt_sum(i,J) = 0.0 ; Corv_bt_sum(i,J) = 0.0 - vbt_wtd(i,J) = 0.0 ; vbt_trans(I,j) = 0.0 + vbt_wtd(i,J) = 0.0 ; vbt_trans(i,J) = 0.0 enddo ; enddo ! Set the mass source, after first initializing the halos to 0. !$OMP do do j=jsvf-1,jevf+1; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo - if (CS%bound_BT_corr) then ; if (use_BT_Cont .and. CS%BT_cont_bounds) then + if (CS%bound_BT_corr) then ; if ((use_BT_Cont.or.integral_BT_cont) .and. CS%BT_cont_bounds) then do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (CS%eta_cor(i,j) > 0.0) then ! Limit the source (outward) correction to be a fraction the mass that - ! can be transported out of the cell by velocities with a CFL number of - ! CFL_cor. - u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) - v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) - eta_cor_max = dt * (CS%IareaT(i,j) * & - (((find_uhbt(u_max_cor, BTCL_u(I,j), US) + uhbt0(I,j)) - & - (find_uhbt(-u_max_cor, BTCL_u(I-1,j), US) + uhbt0(I-1,j))) + & - ((find_vhbt(v_max_cor, BTCL_v(i,J), US) + vhbt0(i,J)) - & - (find_vhbt(-v_max_cor, BTCL_v(i,J-1), US) + vhbt0(i,J-1))) )) + ! can be transported out of the cell by velocities with a CFL number of CFL_cor. + if (integral_BT_cont) then + uint_cor = G%dxT(i,j) * CS%maxCFL_BT_cont + vint_cor = G%dyT(i,j) * CS%maxCFL_BT_cont + eta_cor_max = (CS%IareaT(i,j) * & + (((find_uhbt(uint_cor, BTCL_u(I,j)) + dt*uhbt0(I,j)) - & + (find_uhbt(-uint_cor, BTCL_u(I-1,j)) + dt*uhbt0(I-1,j))) + & + ((find_vhbt(vint_cor, BTCL_v(i,J)) + dt*vhbt0(i,J)) - & + (find_vhbt(-vint_cor, BTCL_v(i,J-1)) + dt*vhbt0(i,J-1))) )) + else ! (use_BT_Cont) then + u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) + v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) + eta_cor_max = dt * (CS%IareaT(i,j) * & + (((find_uhbt(u_max_cor, BTCL_u(I,j)) + uhbt0(I,j)) - & + (find_uhbt(-u_max_cor, BTCL_u(I-1,j)) + uhbt0(I-1,j))) + & + ((find_vhbt(v_max_cor, BTCL_v(i,J)) + vhbt0(i,J)) - & + (find_vhbt(-v_max_cor, BTCL_v(i,J-1)) + vhbt0(i,J-1))) )) + endif CS%eta_cor(i,j) = min(CS%eta_cor(i,j), max(0.0, eta_cor_max)) else - ! Limit the sink (inward) correction to the amount of mass that is already - ! inside the cell. + ! Limit the sink (inward) correction to the amount of mass that is already inside the cell. Htot = eta(i,j) if (GV%Boussinesq) Htot = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) @@ -1677,16 +1759,41 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call find_face_areas(Datu, Datv, G, GV, US, CS, MS, eta, 1+iev-ie) endif + if (integral_BT_cont) then + !GOMP parallel do default(shared) + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + ubt_int_prev(I,j) = ubt_int(I,j) ; uhbt_int_prev(I,j) = uhbt_int(I,j) + enddo ; enddo + !GOMP parallel do default(shared) + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vbt_int_prev(i,J) = vbt_int(i,J) ; vhbt_int_prev(i,J) = vhbt_int(i,J) + enddo ; enddo + endif + !GOMP parallel default(shared) if (CS%dynamic_psurf .or. .not.project_velocity) then - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + uhbt_int(I,j) = find_uhbt(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + enddo ; enddo + !GOMP do + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vhbt_int(i,J) = find_vhbt(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + enddo ; enddo + !GOMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_pred(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do j=jsv-1,jev+1 ; do I=isv-2,iev+1 - uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo !GOMP do do J=jsv-2,jev+1 ; do i=isv-1,iev+1 - vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) + vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo !GOMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 @@ -1751,9 +1858,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt !GOMP parallel do default(shared) - do J=jsv-joff,jev+joff ; do i=isv-1,iev - ubt_prev(i,J) = ubt(i,J) ; uhbt_prev(i,J) = uhbt(i,J) - ubt_sum_prev(i,J) = ubt_sum(i,J) ; uhbt_sum_prev(i,J) = uhbt_sum(i,J) ; ubt_wtd_prev(i,J) = ubt_wtd(i,J) + do j=jsv-joff,jev+joff ; do I=isv-1,iev + ubt_prev(I,j) = ubt(I,j) ; uhbt_prev(I,j) = uhbt(I,j) + ubt_sum_prev(I,j) = ubt_sum(I,j) ; uhbt_sum_prev(I,j) = uhbt_sum(I,j) ; ubt_wtd_prev(I,j) = ubt_wtd(I,j) enddo ; enddo endif @@ -1798,17 +1905,25 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev if (CS%linear_wave_drag) then - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * & + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) else - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do J=jsv-1,jev ; do i=isv-1,iev+1 + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + ! Estimate the mass flux within a single timestep to take the filtered average. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do J=jsv-1,jev ; do i=isv-1,iev+1 - vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo else !GOMP do @@ -1862,10 +1977,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif enddo ; enddo - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do j=jsv,jev ; do I=isv-1,iev + ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) + uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + ! Estimate the mass flux within a single timestep to take the filtered average. + uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do j=jsv,jev ; do I=isv-1,iev - uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo else !GOMP do @@ -1873,10 +1996,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif - if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. + if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP do do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) + ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif else @@ -1921,10 +2044,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif enddo ; enddo - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do j=jsv-1,jev+1 ; do I=isv-1,iev + ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) + uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + ! Estimate the mass flux within a single timestep to take the filtered average. + uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do j=jsv-1,jev+1 ; do I=isv-1,iev - uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo else !GOMP do @@ -1935,7 +2066,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP do do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) + ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif @@ -1983,16 +2114,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev if (CS%linear_wave_drag) then - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * & + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) else - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo - if (use_BT_cont) then + if (integral_BT_cont) then !GOMP do do J=jsv-1,jev ; do i=isv,iev - vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + ! Estimate the mass flux within a single timestep to take the filtered average. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then + !GOMP do + do J=jsv-1,jev ; do i=isv,iev + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo else !GOMP do @@ -2009,6 +2148,27 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif !GOMP end parallel + if (CS%debug_bt) then + write(mesg,'("BT vel update ",I4)') n + call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, haloshift=iev-ie) + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_to_m**2*GV%H_to_m) + endif + + !GOMP parallel default(shared) if (find_PF) then !GOMP do @@ -2046,42 +2206,35 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP end parallel if (apply_OBCs) then - if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP parallel do default(shared) - do j=js,je ; do I=is-1,ie - if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt_sum(I,j) = ubt_sum_prev(I,j) ; uhbt_sum(I,j) = uhbt_sum_prev(I,j) - ubt_wtd(I,j) = ubt_wtd_prev(I,j) - endif - enddo ; enddo - endif - - if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP parallel do default(shared) - do J=js-1,je ; do I=is,ie - if (OBC%segnum_v(i,J) /= OBC_NONE) then - vbt_sum(i,J) = vbt_sum_prev(i,J) ; vhbt_sum(i,J) = vhbt_sum_prev(i,J) - vbt_wtd(i,J) = vbt_wtd_prev(i,J) - endif - enddo ; enddo - endif call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & - ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v, & - uhbt0, vhbt0) + ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & + G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + n*dtbt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & + ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) + if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) - uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) - ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) + ! Update the summed and integrated quantities from the saved previous values. + ubt_sum(I,j) = ubt_sum_prev(I,j) + wt_trans(n) * ubt_trans(I,j) + uhbt_sum(I,j) = uhbt_sum_prev(I,j) + wt_trans(n) * uhbt(I,j) + ubt_wtd(I,j) = ubt_wtd_prev(I,j) + wt_vel(n) * ubt(I,j) + if (integral_BT_cont) then + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) + endif endif enddo ; enddo ; endif if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie if (OBC%segnum_v(i,J) /= OBC_NONE) then - vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) - vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) - vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) + ! Update the summed and integrated quantities from the saved previous values. + vbt_sum(i,J) = vbt_sum_prev(i,J) + wt_trans(n) * vbt_trans(i,J) + vhbt_sum(i,J) = vhbt_sum_prev(i,J) + wt_trans(n) * vhbt(i,J) + vbt_wtd(i,J) = vbt_wtd_prev(i,J) + wt_vel(n) * vbt(i,J) + if (integral_BT_cont) then + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) + endif endif enddo ; enddo ; endif endif @@ -2089,14 +2242,27 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug_bt) then call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & + haloshift=iev-ie, scale=US%L_to_m**2*GV%H_to_m) endif - !$OMP parallel do default(shared) - do j=jsv,jev ; do i=isv,iev - eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & - ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) - eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) - enddo ; enddo + + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsv,jev ; do i=isv,iev + eta(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=jsv,jev ; do i=isv,iev + eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & + ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) + enddo ; enddo + endif if (do_hifreq_output) then time_step_end = time_bt_start + real_to_time(n*US%T_to_s*dtbt) @@ -2161,9 +2327,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP parallel do default(shared) do j=js,je ; do I=is-1,ie - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then e_anom(i+1,j) = e_anom(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then e_anom(i,j) = e_anom(i+1,j) endif enddo ; enddo @@ -2172,9 +2341,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. !GOMP parallel do default(shared) do J=js-1,je ; do I=is,ie - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then e_anom(i,j+1) = e_anom(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then e_anom(i,j) = e_anom(i,j+1) endif enddo ; enddo @@ -2273,22 +2445,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Calculate diagnostic quantities. if (query_averaging_enabled(CS%diag)) then - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo - if (use_BT_cont) then - do j=js,je ; do I=is-1,ie - CS%uhbt_IC(I,j) = find_uhbt(ubt_wtd(I,j), BTCL_u(I,j), US) + uhbt0(I,j) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%vhbt_IC(i,J) = find_vhbt(vbt_wtd(i,J), BTCL_v(i,J), US) + vhbt0(i,J) - enddo ; enddo - else - do j=js,je ; do I=is-1,ie - CS%uhbt_IC(I,j) = ubt_wtd(I,j) * Datu(I,j) + uhbt0(I,j) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%vhbt_IC(i,J) = vbt_wtd(i,J) * Datv(i,J) + vhbt0(i,J) - enddo ; enddo + if (CS%gradual_BT_ICs) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo endif ! Offer various barotropic terms for averaging. @@ -2364,18 +2523,86 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%id_BTC_FA_u_WW > 0) call post_data(CS%id_BTC_FA_u_WW, BT_cont%FA_u_WW, CS%diag) if (CS%id_BTC_uBT_EE > 0) call post_data(CS%id_BTC_uBT_EE, BT_cont%uBT_EE, CS%diag) if (CS%id_BTC_uBT_WW > 0) call post_data(CS%id_BTC_uBT_WW, BT_cont%uBT_WW, CS%diag) + if (CS%id_BTC_FA_u_rat0 > 0) then + tmp_u(:,:) = 0.0 + do j=js,je ; do I=is-1,ie + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0)) then + tmp_u(I,j) = (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j)) + else + tmp_u(I,j) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_u_rat0, tmp_u, CS%diag) + endif if (CS%id_BTC_FA_v_NN > 0) call post_data(CS%id_BTC_FA_v_NN, BT_cont%FA_v_NN, CS%diag) if (CS%id_BTC_FA_v_N0 > 0) call post_data(CS%id_BTC_FA_v_N0, BT_cont%FA_v_N0, CS%diag) if (CS%id_BTC_FA_v_S0 > 0) call post_data(CS%id_BTC_FA_v_S0, BT_cont%FA_v_S0, CS%diag) if (CS%id_BTC_FA_v_SS > 0) call post_data(CS%id_BTC_FA_v_SS, BT_cont%FA_v_SS, CS%diag) if (CS%id_BTC_vBT_NN > 0) call post_data(CS%id_BTC_vBT_NN, BT_cont%vBT_NN, CS%diag) if (CS%id_BTC_vBT_SS > 0) call post_data(CS%id_BTC_vBT_SS, BT_cont%vBT_SS, CS%diag) + if (CS%id_BTC_FA_v_rat0 > 0) then + tmp_v(:,:) = 0.0 + do J=js-1,je ; do i=is,ie + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0)) then + tmp_v(i,J) = (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J)) + else + tmp_v(i,J) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_v_rat0, tmp_v, CS%diag) + endif + if (CS%id_BTC_FA_h_rat0 > 0) then + tmp_h(:,:) = 0.0 + do j=js,je ; do i=is,ie + tmp_h(i,j) = 1.0 + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0) .and. (BT_cont%FA_u_E0(I,j) > 0.0)) then + if (BT_cont%FA_u_W0(I,j) > BT_cont%FA_u_E0(I,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I,j)/ BT_cont%FA_u_E0(I,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j))) + endif + endif + if ((G%mask2dCu(I-1,j) > 0.0) .and. (BT_cont%FA_u_W0(I-1,j) > 0.0) .and. (BT_cont%FA_u_E0(I-1,j) > 0.0)) then + if (BT_cont%FA_u_W0(I-1,j) > BT_cont%FA_u_E0(I-1,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I-1,j)/ BT_cont%FA_u_E0(I-1,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I-1,j)/ BT_cont%FA_u_W0(I-1,j))) + endif + endif + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0) .and. (BT_cont%FA_v_N0(i,J) > 0.0)) then + if (BT_cont%FA_v_S0(i,J) > BT_cont%FA_v_N0(i,J)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J)/ BT_cont%FA_v_N0(i,J))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J))) + endif + endif + if ((G%mask2dCv(i,J-1) > 0.0) .and. (BT_cont%FA_v_S0(i,J-1) > 0.0) .and. (BT_cont%FA_v_N0(i,J-1) > 0.0)) then + if (BT_cont%FA_v_S0(i,J-1) > BT_cont%FA_v_N0(i,J-1)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J-1)/ BT_cont%FA_v_N0(i,J-1))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J-1)/ BT_cont%FA_v_S0(i,J-1))) + endif + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_h_rat0, tmp_h, CS%diag) + endif endif else if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) endif + if ((present(ADp)) .and. (associated(ADp%diag_hfrac_u))) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%diag_hfrac_u(I,j,k) = CS%frhatu(I,j,k) + enddo ; enddo ; enddo + endif + if ((present(ADp)) .and. (associated(ADp%diag_hfrac_v))) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%diag_hfrac_v(i,J,k) = CS%frhatv(i,J,k) + enddo ; enddo ; enddo + endif + if (G%nonblocking_updates) then if (find_etaav) call complete_group_pass(CS%pass_etaav, G%Domain) call complete_group_pass(CS%pass_ubta_uhbta, G%Domain) @@ -2504,10 +2731,10 @@ end subroutine set_dtbt !> The following 4 subroutines apply the open boundary conditions. !! This subroutine applies the open boundary conditions on barotropic !! velocities and mass transports, as developed by Mehmet Ilicak. -subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, & - eta, ubt_old, vbt_old, BT_OBC, & - G, MS, US, halo, dtbt, bebt, use_BT_cont, Datu, Datv, & - BTCL_u, BTCL_v, uhbt0, vhbt0) +subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, & + ubt_old, vbt_old, BT_OBC, G, MS, US, halo, dtbt, bebt, & + use_BT_cont, integral_BT_cont, dt_elapsed, Datu, Datv, & + BTCL_u, BTCL_v, uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int, vhbt_int) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of @@ -2539,6 +2766,11 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! in determining the transport. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping + !! that will have elapsed [T ~> s]. real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2557,6 +2789,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! the barotropic functions agree with the sum !! of the layer transports !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int !< The time-integrated zonal barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int !< The time-integrated zonal barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int !< The time-integrated meridional barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int !< The time-integrated meridional barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. ! Local variables real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. @@ -2567,14 +2807,21 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: cfl ! The CFL number at the point in question [nondim] real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1] real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1] - real :: h_in + real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3] + real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3] + real :: h_in ! The inflow thickess [H ~> m or kg m-2]. real :: cff, Cx, Cy, tau real :: dhdt, dhdx, dhdy + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je real, dimension(SZIB_(G),SZJB_(G)) :: grad real, parameter :: eps = 1.0e-20 is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + if (.not.(BT_OBC%apply_u_OBCs .or. BT_OBC%apply_v_OBCs)) return + + Idtbt = 1.0 / dtbt + if (BT_OBC%apply_u_OBCs) then do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then if (OBC%segment(OBC%segnum_u(I,j))%specified) then @@ -2614,8 +2861,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then - if (use_BT_cont) then - uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j), US) + uhbt0(I,j) + if (integral_BT_cont) then + uhbt_int_new = find_uhbt(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j)) + & + dt_elapsed*uhbt0(I,j) + uhbt(I,j) = (uhbt_int_new - uhbt_int(I,j)) * Idtbt + elseif (use_BT_cont) then + uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) else uhbt(I,j) = Datu(I,j)*vel_trans + uhbt0(I,j) endif @@ -2633,7 +2884,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, vel_trans = vbt(i,J) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal @@ -2649,7 +2900,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal @@ -2666,10 +2917,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then - if (use_BT_cont) then - vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J), US) + vhbt0(i,J) + if (integral_BT_cont) then + vhbt_int_new = find_vhbt(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J)) + & + dt_elapsed*vhbt0(i,J) + vhbt(i,J) = (vhbt_int_new - vhbt_int(i,J)) * Idtbt + elseif (use_BT_cont) then + vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) else - vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) + vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) endif endif @@ -2681,7 +2936,8 @@ end subroutine apply_velocity_OBCs !> This subroutine sets up the private structure used to apply the open !! boundary conditions, as developed by Mehmet Ilicak. -subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v) +subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, & + integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. @@ -2697,6 +2953,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B integer, intent(in) :: halo !< The extra halo size to use here. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of + !! updates to the barotropic solver [T ~> s] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2709,18 +2970,19 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B !! v-points. ! Local variables + real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. integer :: i, j, k, is, ie, js, je, n, nz, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw logical :: OBC_used type(OBC_segment_type), pointer :: segment !< Open boundary segment - is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB isdw = MS%isdw ; iedw = MS%iedw ; jsdw = MS%jsdw ; jedw = MS%jedw + I_dt = 1.0 / dt_baroclinic if ((isdw < isd) .or. (jsdw < jsd)) then call MOM_error(FATAL, "set_up_BT_OBC: Open boundary conditions are not "//& @@ -2764,8 +3026,10 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ! Can this go in segment loop above? Is loop above wrong for wide halos?? if (OBC%segment(OBC%segnum_u(I,j))%specified) then - if (use_BT_cont) then - BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j), BTCL_u(I,j), US) + if (integral_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j)*dt_baroclinic, BTCL_u(I,j)) * I_dt + elseif (use_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j), BTCL_u(I,j)) else if (Datu(I,j) > 0.0) BT_OBC%ubt_outer(I,j) = BT_OBC%uhbt(I,j) / Datu(I,j) endif @@ -2816,8 +3080,10 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then ! Can this go in segment loop above? Is loop above wrong for wide halos?? if (OBC%segment(OBC%segnum_v(i,J))%specified) then - if (use_BT_cont) then - BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J), BTCL_v(i,J), US) + if (integral_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J)*dt_baroclinic, BTCL_v(i,J)) * I_dt + elseif (use_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J), BTCL_v(i,J)) else if (Datv(i,J) > 0.0) BT_OBC%vbt_outer(i,J) = BT_OBC%vhbt(i,J) / Datv(i,J) endif @@ -3158,15 +3424,17 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) end subroutine btcalc -!> The function find_uhbt determines the zonal transport for a given velocity. -function find_uhbt(u, BTC, US) result(uhbt) - real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] +!> The function find_uhbt determines the zonal transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated zonal transport for a given +!! time-integrated velocity. +function find_uhbt(u, BTC) result(uhbt) + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. - real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] + real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] if (u == 0.0) then uhbt = 0.0 @@ -3182,14 +3450,14 @@ function find_uhbt(u, BTC, US) result(uhbt) end function find_uhbt -!> The function find_duhbt_du determines the marginal zonal face area for a given velocity. -function find_duhbt_du(u, BTC, US) result(duhbt_du) - real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] +!> The function find_duhbt_du determines the marginal zonal face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_duhbt_du(u, BTC) result(duhbt_du) + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. real :: duhbt_du !< The zonal barotropic face area [L H ~> m2] if (u == 0.0) then @@ -3206,25 +3474,30 @@ function find_duhbt_du(u, BTC, US) result(duhbt_du) end function find_duhbt_du - !> This function inverts the transport function to determine the barotopic -!! velocity that is consistent with a given transport. -function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function uhbt_to_ubt(uhbt, BTC, guess) result(ubt) real, intent(in) :: uhbt !< The barotropic zonal transport that should be inverted for, - !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! [H L2 T-1 ~> m3 s-1 or kg s-1] or the time-integrated + !! transport [H L2 ~> m3 or kg]. type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that allow the !! barotropic transports to be calculated consistently with the - !! layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, optional, intent(in) :: guess !< A guess at what ubt will be [L T-1 ~> m s-1]. The result - !! is not allowed to be dramatically larger than guess. - real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1]. + !! layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real, optional, intent(in) :: guess !< A guess at what ubt will be [L T-1 ~> m s-1] or [L ~> m]. + !! The result is not allowed to be dramatically larger than guess. + real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. ! Local variables - real :: ubt_min, ubt_max, uhbt_err, derr_du - real :: uherr_min, uherr_max + real :: ubt_min, ubt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: uhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_du ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1]. + real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the @@ -3292,7 +3565,7 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) if (dvel > 0.0) then ! Limit the velocity if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1))) - else ! The exp be less than 4e-18 anyway in this case, so neglect it. + else ! The exp is less than 4e-18 anyway in this case, so neglect it. vsr = vs2 endif ubt = SIGN(vsr * guess, ubt) @@ -3301,14 +3574,16 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) end function uhbt_to_ubt -!> The function find_vhbt determines the meridional transport for a given velocity. -function find_vhbt(v, BTC, US) result(vhbt) - real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] +!> The function find_vhbt determines the meridional transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated meridional transport for a given +!! time-integrated velocity. +function find_vhbt(v, BTC) result(vhbt) + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] if (v == 0.0) then vhbt = 0.0 @@ -3324,13 +3599,14 @@ function find_vhbt(v, BTC, US) result(vhbt) end function find_vhbt -!> The function find_vhbt determines the meridional transport for a given velocity. -function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) - real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] +!> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_dvhbt_dv(v, BTC) result(dvhbt_dv) + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2] if (v == 0.0) then @@ -3348,23 +3624,29 @@ function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) end function find_dvhbt_dv !> This function inverts the transport function to determine the barotopic -!! velocity that is consistent with a given transport. -function vhbt_to_vbt(vhbt, BTC, US, guess) result(vbt) +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function vhbt_to_vbt(vhbt, BTC, guess) result(vbt) real, intent(in) :: vhbt !< The barotropic meridional transport that should be - !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1] or the + !! time-integrated transport [H L2 ~> m3 or kg]. type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that allow the !! barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, optional, intent(in) :: guess !< A guess at what vbt will be. The result is not allowed - !! to be dramatically larger than guess [L T-1 ~> m s-1]. - real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1]. + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real, optional, intent(in) :: guess !< A guess at what vbt will be [L T-1 ~> m s-1] or [L ~> m]. + !! The result is not allowed to be dramatically larger than guess. + real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. ! Local variables - real :: vbt_min, vbt_max, vhbt_err, derr_dv - real :: vherr_min, vherr_max + real :: vbt_min, vbt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: vhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_dv ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1]. + real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the @@ -3432,7 +3714,7 @@ function vhbt_to_vbt(vhbt, BTC, US, guess) result(vbt) if (dvel > 0.0) then ! Limit the velocity if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1))) - else ! The exp be less than 4e-18 anyway in this case, so neglect it. + else ! The exp is less than 4e-18 anyway in this case, so neglect it. vsr = vs2 endif vbt = SIGN(guess * vsr, vbt) @@ -3443,7 +3725,7 @@ end function vhbt_to_vbt !> This subroutine sets up reordered versions of the BT_cont type in the !! local_BT_cont types, which have wide halos properly filled in. -subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo) +subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo, dt_baroclinic) type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the !! barotropic solver. type(memory_size_type), intent(in) :: MS !< A type that describes the @@ -3458,16 +3740,26 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain type(MOM_domain_type), intent(inout) :: BT_Domain !< The domain to use for updating !! the halos of wide arrays. integer, optional, intent(in) :: halo !< The extra halo size to use here. + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step + !! [T ~> s], which is provided if + !! INTEGRAL_BT_CONTINUITY is true. ! Local variables real, dimension(SZIBW_(MS),SZJW_(MS)) :: & - u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW + u_polarity, & ! An array used to test for halo update polarity [nondim] + uBT_EE, uBT_WW, & ! Zonal velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW ! Zonal face areas [H L ~> m2 or kg m-1] real, dimension(SZIW_(MS),SZJBW_(MS)) :: & - v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS + v_polarity, & ! An array used to test for halo update polarity [nondim] + vBT_NN, vBT_SS, & ! Meridional velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS ! Meridional face areas [H L ~> m2 or kg m-1] + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] real, parameter :: C1_3 = 1.0/3.0 integer :: i, j, is, ie, js, je, hs + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = 1 ; if (present(halo)) hs = max(halo,0) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays. !$OMP parallel default(none) shared(is,ie,js,je,hs,u_polarity,uBT_EE,uBT_WW,FA_u_EE, & @@ -3517,15 +3809,12 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) -!$OMP parallel default(none) shared(is,ie,js,je,hs,BTCL_u,FA_u_EE,FA_u_E0,FA_u_W0, & -!$OMP FA_u_WW,uBT_EE,uBT_WW,u_polarity,BTCL_v, & -!$OMP FA_v_NN,FA_v_N0,FA_v_S0,FA_v_SS,vBT_NN,vBT_SS, & -!$OMP v_polarity ) -!$OMP do + !$OMP parallel default(shared) + !$OMP do do j=js-hs,je+hs ; do I=is-hs-1,ie+hs BTCL_u(I,j)%FA_u_EE = FA_u_EE(I,j) ; BTCL_u(I,j)%FA_u_E0 = FA_u_E0(I,j) BTCL_u(I,j)%FA_u_W0 = FA_u_W0(I,j) ; BTCL_u(I,j)%FA_u_WW = FA_u_WW(I,j) - BTCL_u(I,j)%uBT_EE = uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = uBT_WW(I,j) + BTCL_u(I,j)%uBT_EE = dt*uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = dt*uBT_WW(I,j) ! Check for reversed polarity in the tripolar halo regions. if (u_polarity(I,j) < 0.0) then call swap(BTCL_u(I,j)%FA_u_EE, BTCL_u(I,j)%FA_u_WW) @@ -3544,11 +3833,11 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (abs(BTCL_u(I,j)%uBT_EE) > 0.0) BTCL_u(I,j)%uh_crvE = & (C1_3 * (BTCL_u(I,j)%FA_u_EE - BTCL_u(I,j)%FA_u_E0)) / BTCL_u(I,j)%uBT_EE**2 enddo ; enddo -!$OMP do + !$OMP do do J=js-hs-1,je+hs ; do i=is-hs,ie+hs BTCL_v(i,J)%FA_v_NN = FA_v_NN(i,J) ; BTCL_v(i,J)%FA_v_N0 = FA_v_N0(i,J) BTCL_v(i,J)%FA_v_S0 = FA_v_S0(i,J) ; BTCL_v(i,J)%FA_v_SS = FA_v_SS(i,J) - BTCL_v(i,J)%vBT_NN = vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = vBT_SS(i,J) + BTCL_v(i,J)%vBT_NN = dt*vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = dt*vBT_SS(i,J) ! Check for reversed polarity in the tripolar halo regions. if (v_polarity(i,J) < 0.0) then call swap(BTCL_v(i,J)%FA_v_NN, BTCL_v(i,J)%FA_v_SS) @@ -3567,14 +3856,16 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (abs(BTCL_v(i,J)%vBT_NN) > 0.0) BTCL_v(i,J)%vh_crvN = & (C1_3 * (BTCL_v(i,J)%FA_v_NN - BTCL_v(i,J)%FA_v_N0)) / BTCL_v(i,J)%vBT_NN**2 enddo ; enddo -!$OMP end parallel + !$OMP end parallel end subroutine set_local_BT_cont_types -!> Adjust_local_BT_cont_types sets up reordered versions of the BT_cont type -!! in the local_BT_cont types, which have wide halos properly filled in. +!> Adjust_local_BT_cont_types expands the range of velocities with a cubic curve +!! translating velocities into transports to match the inital values of velocities and +!! summed transports when the velocities are larger than the first guesses of the cubic +!! transition velocities used to set up the local_BT_cont types. subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, halo) + G, US, MS, halo, dt_baroclinic) type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. real, dimension(SZIBW_(MS),SZJW_(MS)), & intent(in) :: ubt !< The linearization zonal barotropic velocity [L T-1 ~> m s-1]. @@ -3593,73 +3884,78 @@ subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The extra halo size to use here. + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step [T ~> s], which is + !! provided if INTEGRAL_BT_CONTINUITY is true. ! Local variables real, dimension(SZIBW_(MS),SZJW_(MS)) :: & u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW real, dimension(SZIW_(MS),SZJBW_(MS)) :: & v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] real, parameter :: C1_3 = 1.0/3.0 integer :: i, j, is, ie, js, je, hs + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = 1 ; if (present(halo)) hs = max(halo,0) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic !$OMP parallel do default(shared) do j=js-hs,je+hs ; do I=is-hs-1,ie+hs - if ((ubt(I,j) > BTCL_u(I,j)%uBT_WW) .and. (uhbt(I,j) > BTCL_u(I,j)%uh_WW)) then + if ((dt*ubt(I,j) > BTCL_u(I,j)%uBT_WW) .and. (dt*uhbt(I,j) > BTCL_u(I,j)%uh_WW)) then ! Expand the cubic fit to use this new point. ubt is negative. - BTCL_u(I,j)%ubt_WW = ubt(I,j) + BTCL_u(I,j)%ubt_WW = dt * ubt(I,j) if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_W0) then ! No further bounding is needed. - BTCL_u(I,j)%uh_crvW = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_W0) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvW = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_W0) / (dt**2 * ubt(I,j)**3) else ! This should not happen often! BTCL_u(I,j)%FA_u_W0 = 1.5*uhbt(I,j) / ubt(I,j) - BTCL_u(I,j)%uh_crvW = -0.5*uhbt(I,j) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvW = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) endif - BTCL_u(I,j)%uh_WW = uhbt(I,j) + BTCL_u(I,j)%uh_WW = dt * uhbt(I,j) ! I don't know whether this is helpful. ! BTCL_u(I,j)%FA_u_WW = min(BTCL_u(I,j)%FA_u_WW, uhbt(I,j) / ubt(I,j)) - elseif ((ubt(I,j) < BTCL_u(I,j)%uBT_EE) .and. (uhbt(I,j) < BTCL_u(I,j)%uh_EE)) then + elseif ((dt*ubt(I,j) < BTCL_u(I,j)%uBT_EE) .and. (dt*uhbt(I,j) < BTCL_u(I,j)%uh_EE)) then ! Expand the cubic fit to use this new point. ubt is negative. - BTCL_u(I,j)%ubt_EE = ubt(I,j) + BTCL_u(I,j)%ubt_EE = dt * ubt(I,j) if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_E0) then ! No further bounding is needed. - BTCL_u(I,j)%uh_crvE = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_E0) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvE = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_E0) / (dt**2 * ubt(I,j)**3) else ! This should not happen often! BTCL_u(I,j)%FA_u_E0 = 1.5*uhbt(I,j) / ubt(I,j) - BTCL_u(I,j)%uh_crvE = -0.5*uhbt(I,j) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvE = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) endif - BTCL_u(I,j)%uh_EE = uhbt(I,j) + BTCL_u(I,j)%uh_EE = dt * uhbt(I,j) ! I don't know whether this is helpful. ! BTCL_u(I,j)%FA_u_EE = min(BTCL_u(I,j)%FA_u_EE, uhbt(I,j) / ubt(I,j)) endif enddo ; enddo !$OMP parallel do default(shared) do J=js-hs-1,je+hs ; do i=is-hs,ie+hs - if ((vbt(i,J) > BTCL_v(i,J)%vBT_SS) .and. (vhbt(i,J) > BTCL_v(i,J)%vh_SS)) then + if ((dt*vbt(i,J) > BTCL_v(i,J)%vBT_SS) .and. (dt*vhbt(i,J) > BTCL_v(i,J)%vh_SS)) then ! Expand the cubic fit to use this new point. vbt is negative. - BTCL_v(i,J)%vbt_SS = vbt(i,J) + BTCL_v(i,J)%vbt_SS = dt * vbt(i,J) if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_S0) then ! No further bounding is needed. - BTCL_v(i,J)%vh_crvS = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_S0) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvS = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_S0) / (dt**2 * vbt(i,J)**3) else ! This should not happen often! BTCL_v(i,J)%FA_v_S0 = 1.5*vhbt(i,J) / (vbt(i,J)) - BTCL_v(i,J)%vh_crvS = -0.5*vhbt(i,J) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvS = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) endif - BTCL_v(i,J)%vh_SS = vhbt(i,J) + BTCL_v(i,J)%vh_SS = dt * vhbt(i,J) ! I don't know whether this is helpful. ! BTCL_v(i,J)%FA_v_SS = min(BTCL_v(i,J)%FA_v_SS, vhbt(i,J) / vbt(i,J)) - elseif ((vbt(i,J) < BTCL_v(i,J)%vBT_NN) .and. (vhbt(i,J) < BTCL_v(i,J)%vh_NN)) then + elseif ((dt*vbt(i,J) < BTCL_v(i,J)%vBT_NN) .and. (dt*vhbt(i,J) < BTCL_v(i,J)%vh_NN)) then ! Expand the cubic fit to use this new point. vbt is negative. - BTCL_v(i,J)%vbt_NN = vbt(i,J) + BTCL_v(i,J)%vbt_NN = dt * vbt(i,J) if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_N0) then ! No further bounding is needed. - BTCL_v(i,J)%vh_crvN = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_N0) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvN = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_N0) / (dt**2 * vbt(i,J)**3) else ! This should not happen often! BTCL_v(i,J)%FA_v_N0 = 1.5*vhbt(i,J) / (vbt(i,J)) - BTCL_v(i,J)%vh_crvN = -0.5*vhbt(i,J) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvN = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) endif - BTCL_v(i,J)%vh_NN = vhbt(i,J) + BTCL_v(i,J)%vh_NN = dt * vhbt(i,J) ! I don't know whether this is helpful. ! BTCL_v(i,J)%FA_v_NN = min(BTCL_v(i,J)%FA_v_NN, vhbt(i,J) / vbt(i,J)) endif @@ -3839,8 +4135,6 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) real :: d_eta ! The difference between estimates of the total ! thicknesses [H ~> m or kg m-2]. integer :: is, ie, js, je, nz, i, j, k - real, parameter :: frac_cor = 0.25 - real, parameter :: slow_rate = 0.125 if (.not.associated(CS)) call MOM_error(FATAL, "bt_mass_source: "// & "Module MOM_barotropic must be initialized before it is used.") @@ -3973,6 +4267,19 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "Use the split time stepping if true.", default=.true.) if (.not.CS%split) return + call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & + "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.", default=.true.) + call get_param(param_file, mdl, "INTEGRAL_BT_CONTINUITY", CS%integral_bt_cont, & + "If true, use the time-integrated velocity over the barotropic steps "//& + "to determine the integrated transports used to update the continuity "//& + "equation. Otherwise the transports are the sum of the transports based on "//& + "a series of instantaneous velocities and the BT_CONT_TYPE for transports. "//& + "This is only valid if USE_BT_CONT_TYPE = True.", & + default=.false., do_not_log=.not.use_BT_cont_type) call get_param(param_file, mdl, "BOUND_BT_CORRECTION", CS%bound_BT_corr, & "If true, the corrective pseudo mass-fluxes into the "//& "barotropic solver are limited to values that require "//& @@ -3982,11 +4289,12 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "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) + 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 "//& "that is used by the barotropic solver to match the "//& - "transport about which the flow is being linearized.", default=.false.) + "transport about which the flow is being linearized.", & + default=.false., do_not_log=.not.use_BT_cont_type) call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & "If true, adjust the initial conditions for the "//& "barotropic solver to the values from the layered "//& @@ -4020,25 +4328,16 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "The barotropic y-halo size that is actually used.", & 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 "//& - "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, & + call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", CS%Nonlinear_continuity, & "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, & + "USE_BT_CONT_TYPE is true.", default=.false., do_not_log=use_BT_cont_type) + 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 "//& "of barotropic time steps between updates to the face "//& - "areas, or 0 to update only before the barotropic stepping.",& - units="nondim", default=1) + "areas, or 0 to update only before the barotropic stepping.", & + units="nondim", default=1, do_not_log=.not.CS%Nonlinear_continuity) + call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", CS%BT_project_velocity,& "If true, step the barotropic velocity first and project "//& "out the velocity tendency by 1+BEBT when calculating the "//& @@ -4055,22 +4354,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & "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, & + call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & "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, scale=US%m_to_L) - 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 "//& - "dynamic surface pressure for stability, if "//& - "DYNAMIC_SURFACE_PRESSURE is true..", & - units="m", default=1.0e-6, scale=US%m_to_Z) - call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & + units="m", default=1.0e4, scale=US%m_to_L, do_not_log=.not.CS%dynamic_psurf) + 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 "//& + "dynamic surface pressure for stability, if "//& + "DYNAMIC_SURFACE_PRESSURE is true..", & + units="m", default=1.0e-6, scale=US%m_to_Z, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & "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 + "are < ~1.0.", units="nondim", default=0.9, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "BT_CORIOLIS_SCALE", CS%BT_Coriolis_scale, & "A factor by which the barotropic Coriolis anomaly terms are scaled.", & units="nondim", default=1.0) @@ -4295,7 +4593,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%IdxCu(I,j) = G%IdxCu(I,j) ; CS%dy_Cu(I,j) = G%dy_Cu(I,j) enddo ; enddo do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - CS%IdyCv(I,j) = G%IdyCv(I,j) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) + CS%IdyCv(i,J) = G%IdyCv(i,J) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) enddo ; enddo call create_group_pass(pass_static_data, CS%IareaT, CS%BT_domain, To_All) call create_group_pass(pass_static_data, CS%bathyT, CS%BT_domain, To_All) @@ -4385,7 +4683,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call log_param(param_file, mdl, "DTBT as used", CS%dtbt*US%T_to_s) call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max*US%T_to_s) - ! ubtav, vbtav, ubt_IC, vbt_IC, uhbt_IC, and vhbt_IC are allocated and + ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and ! initialized in register_barotropic_restarts. if (GV%Boussinesq) then @@ -4488,6 +4786,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'BTCont type far east velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_ubt_WW = register_diag_field('ocean_model', 'BTC_ubt_WW', diag%axesCu1, Time, & 'BTCont type far west velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_u_rat0 = register_diag_field('ocean_model', 'BTC_FA_u_rat0', diag%axesCu1, Time, & + ! 'BTCont type ratio of near east and west face areas', 'nondim') CS%id_BTC_FA_v_NN = register_diag_field('ocean_model', 'BTC_FA_v_NN', diag%axesCv1, Time, & 'BTCont type far north face area', 'm2', conversion=US%L_to_m*GV%H_to_m) CS%id_BTC_FA_v_N0 = register_diag_field('ocean_model', 'BTC_FA_v_N0', diag%axesCv1, Time, & @@ -4500,6 +4801,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'BTCont type far north velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_vbt_SS = register_diag_field('ocean_model', 'BTC_vbt_SS', diag%axesCv1, Time, & 'BTCont type far south velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_v_rat0 = register_diag_field('ocean_model', 'BTC_FA_v_rat0', diag%axesCv1, Time, & + ! 'BTCont type ratio of near north and south face areas', 'nondim') + ! CS%id_BTC_FA_h_rat0 = register_diag_field('ocean_model', 'BTC_FA_h_rat0', diag%axesT1, Time, & + ! 'BTCont type maximum ratios of near face areas around cells', 'nondim') endif CS%id_uhbt0 = register_diag_field('ocean_model', 'uhbt0', diag%axesCu1, Time, & 'Barotropic zonal transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) @@ -4523,20 +4829,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) do j=js,je ; do I=is-1,ie ; CS%ubtav(I,j) = vel_rescale * CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(i,J) ; enddo ; enddo endif - if (.NOT.query_initialized(CS%ubt_IC,"ubt_IC",restart_CS) .or. & - .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo - elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(I,j) ; enddo ; enddo + if (CS%gradual_BT_ICs) then + if (.NOT.query_initialized(CS%ubt_IC,"ubt_IC",restart_CS) .or. & + .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo + elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & + (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then + vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(i,J) ; enddo ; enddo + endif endif - ! Calculate other constants which are used for btstep. if (.not.CS%nonlin_stress) then @@ -4551,7 +4858,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, do J=js-1,je ; do i=is,ie if (G%mask2dCv(i,J)>0.) then CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL) - else ! Both neighboring H points are masked out so IDatv(I,j) is meaningless + else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless CS%IDatv(i,J) = 0. endif enddo ; enddo @@ -4567,21 +4874,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, enddo ; enddo endif - if (.NOT.query_initialized(CS%uhbt_IC,"uhbt_IC",restart_CS) .or. & - .NOT.query_initialized(CS%vhbt_IC,"vhbt_IC",restart_CS)) then - do j=js,je ; do I=is-1,ie ; CS%uhbt_IC(I,j) = CS%ubtav(I,j) * Datu(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vhbt_IC(i,J) = CS%vbtav(i,J) * Datv(i,J) ; enddo ; enddo - elseif ((US%s_to_T_restart * US%m_to_L_restart * GV%m_to_H_restart /= 0.0) .and. & - ((US%s_to_T_restart * US%m_to_L**2 * GV%m_to_H) /= & - (US%s_to_T * US%m_to_L_restart**2 * GV%m_to_H_restart))) then - uH_rescale = (US%s_to_T_restart * US%m_to_L**2 * GV%m_to_H) / & - (US%s_to_T * US%m_to_L_restart**2 * GV%m_to_H_restart) - do j=js,je ; do I=is-1,ie ; CS%uhbt_IC(I,j) = uH_rescale * CS%uhbt_IC(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vhbt_IC(i,J) = uH_rescale * CS%vhbt_IC(I,j) ; enddo ; enddo - endif - - call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain) - call create_group_pass(pass_bt_hbt_btav, CS%uhbt_IC, CS%vhbt_IC, G%Domain) + if (CS%gradual_BT_ICs) & + call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain) call create_group_pass(pass_bt_hbt_btav, CS%ubtav, CS%vbtav, G%Domain) call do_group_pass(pass_bt_hbt_btav, G%Domain) @@ -4649,7 +4943,7 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) ! Local variables type(vardesc) :: vd(3) - real :: slow_rate + character(len=40) :: mdl = "MOM_barotropic" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed @@ -4662,12 +4956,20 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) endif allocate(CS) + call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & + "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., do_not_log=.true.) + ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 - ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 - ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 - ALLOC_(CS%uhbt_IC(IsdB:IedB,jsd:jed)) ; CS%uhbt_IC(:,:) = 0.0 - ALLOC_(CS%vhbt_IC(isd:ied,JsdB:JedB)) ; CS%vhbt_IC(:,:) = 0.0 + if (CS%gradual_BT_ICs) then + ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 + ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 + endif vd(2) = var_desc("ubtav","m s-1","Time mean barotropic zonal velocity", & hor_grid='u', z_grid='1') @@ -4675,30 +4977,16 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) hor_grid='v', z_grid='1') call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS) - vd(2) = var_desc("ubt_IC", "m s-1", & - longname="Next initial condition for the barotropic zonal velocity", & - hor_grid='u', z_grid='1') - vd(3) = var_desc("vbt_IC", "m s-1", & - longname="Next initial condition for the barotropic meridional velocity",& - hor_grid='v', z_grid='1') - call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) - - if (GV%Boussinesq) then - vd(2) = var_desc("uhbt_IC", "m3 s-1", & - longname="Next initial condition for the barotropic zonal transport", & - hor_grid='u', z_grid='1') - vd(3) = var_desc("vhbt_IC", "m3 s-1", & - longname="Next initial condition for the barotropic meridional transport",& - hor_grid='v', z_grid='1') - else - vd(2) = var_desc("uhbt_IC", "kg s-1", & - longname="Next initial condition for the barotropic zonal transport", & + if (CS%gradual_BT_ICs) then + vd(2) = var_desc("ubt_IC", "m s-1", & + longname="Next initial condition for the barotropic zonal velocity", & hor_grid='u', z_grid='1') - vd(3) = var_desc("vhbt_IC", "kg s-1", & - longname="Next initial condition for the barotropic meridional transport",& + vd(3) = var_desc("vbt_IC", "m s-1", & + longname="Next initial condition for the barotropic meridional velocity",& hor_grid='v', z_grid='1') + call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) endif - call register_restart_pair(CS%uhbt_IC, CS%vhbt_IC, vd(2), vd(3), .false., restart_CS) + call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & longname="Barotropic timestep", units="seconds") diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index c594d31494..995827959d 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -263,6 +263,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & real :: du_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [L ~> m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, local_open_BC, is_simple type(OBC_segment_type), pointer :: segment => NULL() @@ -303,7 +304,8 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & !$OMP uh,dt,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & !$OMP CFL_dt,I_dt,u_cor,BT_cont, local_Flather_OBC) & !$OMP private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0,duhdu_tot_0, & -!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W,any_simple_OBC ) & +!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, & +!$OMP any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do j=jsh,jeh do I=ish-1,ieh ; do_I(I) = .true. ; visc_rem_max(I) = 0.0 ; enddo @@ -318,8 +320,12 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do I=ish-1,ieh - if (OBC%segment(OBC%segnum_u(I,j))%specified) & - uh(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) + endif enddo endif enddo @@ -408,9 +414,13 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & any_simple_OBC = .false. if (present(uhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do I=ish-1,ieh + l_seg = OBC%segnum_u(I,j) + ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%segment(OBC%segnum_u(I,j))%specified - do_I(I) = .not.(OBC%segnum_u(I,j) /= OBC_NONE .and. is_simple) + is_simple = .false. + if (l_seg /= OBC_NONE) & + is_simple = OBC%segment(l_seg)%specified + do_I(I) = .not. (l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do I=ish-1,ieh do_I(I) = .true. @@ -425,8 +435,12 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo if (local_specified_BC) then ; do I=ish-1,ieh - if (OBC%segment(OBC%segnum_u(I,j))%specified) & - u_cor(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + u_cor(I,j,k) = OBC%segment(l_seg)%normal_vel(I,j,k) + endif enddo ; endif enddo ; endif ! u-corrected @@ -438,9 +452,15 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & visc_rem_max, j, ish, ieh, do_I) if (any_simple_OBC) then do I=ish-1,ieh - do_I(I) = OBC%segment(OBC%segnum_u(I,j))%specified + l_seg = OBC%segnum_u(I,j) + + do_I(I) = .false. + if (l_seg /= OBC_NONE) & + do_I(I) = OBC%segment(l_seg)%specified + if (do_I(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) enddo + ! NOTE: do_I(I) should prevent access to segment OBC_NONE do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then if ((abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_u(I,j))%specified)) & @@ -529,6 +549,7 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & ! with the same units as h_in. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i + integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -561,13 +582,17 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & if (local_open_BC) then do I=ish-1,ieh ; if (do_I(I)) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - uh(I) = G%dy_Cu(I,j) * u(I) * h(i) - duhdu(I) = G%dy_Cu(I,j) * h(i) * visc_rem(I) - else - uh(I) = G%dy_Cu(I,j) * u(I) * h(i+1) - duhdu(I) = G%dy_Cu(I,j) * h(i+1) * visc_rem(I) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + uh(I) = G%dy_Cu(I,j) * u(I) * h(i) + duhdu(I) = G%dy_Cu(I,j) * h(i) * visc_rem(I) + else + uh(I) = G%dy_Cu(I,j) * u(I) * h(i+1) + duhdu(I) = G%dy_Cu(I,j) * h(i+1) * visc_rem(I) + endif endif endif endif ; enddo @@ -1062,6 +1087,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & real :: dv_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [L ~> m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, is_simple, local_open_BC type(OBC_segment_type), pointer :: segment => NULL() @@ -1103,7 +1129,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & !$OMP set_BT_cont,CFL_dt,I_dt,v_cor,BT_cont, local_Flather_OBC ) & !$OMP private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & !$OMP dvhdv_tot_0,visc_rem_max,I_vrm,dv_lim,dy_N, & -!$OMP is_simple,FAvi,dy_S,any_simple_OBC ) & +!$OMP is_simple,FAvi,dy_S,any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do J=jsh-1,jeh do i=ish,ieh ; do_I(i) = .true. ; visc_rem_max(I) = 0.0 ; enddo @@ -1118,8 +1144,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do i=ish,ieh - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - vh(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) + endif enddo endif enddo ! k-loop @@ -1204,9 +1234,13 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & any_simple_OBC = .false. if (present(vhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do i=ish,ieh + l_seg = OBC%segnum_v(i,J) + ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%segment(OBC%segnum_v(i,J))%specified - do_I(i) = .not.(OBC%segnum_v(i,J) /= OBC_NONE .and. is_simple) + is_simple = .false. + if (l_seg /= OBC_NONE) & + is_simple = OBC%segment(l_seg)%specified + do_I(i) = .not.(l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do i=ish,ieh do_I(i) = .true. @@ -1221,8 +1255,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo if (local_specified_BC) then ; do i=ish,ieh - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%specified) & + v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + endif enddo ; endif enddo ; endif ! v-corrected endif @@ -1233,9 +1271,15 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & visc_rem_max, J, ish, ieh, do_I) if (any_simple_OBC) then do i=ish,ieh - do_I(i) = (OBC%segment(OBC%segnum_v(i,J))%specified) + l_seg = OBC%segnum_v(i,J) + + do_I(I) = .false. + if(l_seg /= OBC_NONE) & + do_I(i) = (OBC%segment(l_seg)%specified) + if (do_I(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) enddo + ! NOTE: do_I(I) should prevent access to segment OBC_NONE do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then if ((abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_v(i,J))%specified)) & @@ -1327,6 +1371,7 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & ! with the same units as h, i.e. [H ~> m or kg m-2]. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i + integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -1360,13 +1405,17 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & if (local_open_BC) then do i=ish,ieh ; if (do_I(i)) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j) - dvhdv(i) = G%dx_Cv(i,J) * h(i,j) * visc_rem(i) - else - vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j+1) - dvhdv(i) = G%dx_Cv(i,J) * h(i,j+1) * visc_rem(i) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j) + dvhdv(i) = G%dx_Cv(i,J) * h(i,j) * visc_rem(i) + else + vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j+1) + dvhdv(i) = G%dx_Cv(i,J) * h(i,j+1) * visc_rem(i) + endif endif endif endif ; enddo diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 new file mode 100644 index 0000000000..d7d9c95b34 --- /dev/null +++ b/src/core/MOM_density_integrals.F90 @@ -0,0 +1,1655 @@ +!> Provides integrals of density +module MOM_density_integrals + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_quadrature +use MOM_EOS, only : analytic_int_density_dz +use MOM_EOS, only : analytic_int_specific_vol_dp +use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_spec_vol +use MOM_EOS, only : calculate_specific_vol_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_hor_index, only : hor_index_type +use MOM_string_functions, only : uppercase +use MOM_variables, only : thermo_var_ptrs +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public int_density_dz +public int_density_dz_generic_pcm +public int_density_dz_generic_plm +public int_density_dz_generic_ppm +public int_specific_vol_dp +public int_spec_vol_dp_generic_pcm +public int_spec_vol_dp_generic_plm +public find_depth_of_pressure_in_cell + +contains + +!> Calls the appropriate subroutine to calculate analytical and nearly-analytical +!! integrals in z across layers of pressure anomalies, which are +!! required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. +subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude of each of the + !! integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + + if (EOS_quadrature(EOS)) then + call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + else + call analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + endif + +end subroutine int_density_dz + + +!> Calculates (by numerical quadrature) integrals of pressure anomalies across layers, which +!! are required for calculating the finite-volume form pressure accelerations in a Boussinesq model. +subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature of the layer [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity of the layer [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude + !! of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + ! Local variables + real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] + real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] + real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: dz ! The layer thickness [Z ~> m] + real :: hWght ! A pressure-thickness below topography [Z ~> m] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] + logical :: do_massWeight ! Indicates whether to do mass weighting. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "bathyT must be present if useMassWghtInterp is present and true.") + if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + dpa(i,j) = G_e*dz*rho_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the pressure anomaly. + if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo ; enddo ; endif +end subroutine int_density_dz_generic_pcm + + +!> Compute pressure gradient force integrals by quadrature for the case where +!! T and S are linear profiles. +subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & + rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + integer, intent(in) :: k !< Layer index to calculate integrals for + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_t !< Salinity at the cell top [ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate + !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [R L2 Z T-2 ~> Pa Z] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the y grid spacing [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + +! This subroutine calculates (by numerical quadrature) integrals of +! pressure anomalies across layers, which are required for calculating the +! finite-volume form pressure accelerations in a Boussinesq model. The one +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! It is assumed that the salinity and temperature profiles are linear in the +! vertical. The top and bottom values within each layer are provided and +! a linear interpolation is used to compute intermediate values. + + ! Local variables + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [ppt] + real :: T25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] + real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [ppt2] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations, never + ! rescaled from Pa [Pa] + real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid + ! locations [R ~> kg m-3] or [kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [ppt] + real :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS15((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] + real :: S215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS salinity variance along a line of subgrid locations [ppt2] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations + ! [R ~> kg m-3] or [kg m-3] + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + real :: rho_anom ! A density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] + real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m] + real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC] + real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [ppt] + real :: hWght ! A topographically limited thicknes weight [Z ~> m] + real :: hL, hR ! Thicknesses to the left and right [Z ~> m] + real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] + logical :: use_stanley_eos ! True is SGS variance fields exist in tv. + logical :: use_varT, use_varS, use_covarTS + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n + integer :: pos + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) + use_stanley_eos = use_varT .or. use_covarTS .or. use_varS + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + T215(:) = 0. + TS15(:) = 0. + S215(:) = 0. + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 + do i = Isq,Ieq+1 + dz(i) = e(i,j,K) - e(i,j,K+1) + do n=1,5 + p5(i*5+n) = -GxRho*(e(i,j,K) - 0.25*real(n-1)*dz(i)) + ! Salinity and temperature points are linearly interpolated + S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) + T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) + enddo + if (use_varT) T25(i*5+1:i*5+5) = tv%varT(i,j,k) + if (use_covarTS) TS5(i*5+1:i*5+5) = tv%covarTS(i,j,k) + if (use_varS) S25(i*5+1:i*5+5) = tv%varS(i,j,k) + enddo + if (use_Stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & + rho_ref=rho_ref_mks) + endif + else + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, & + scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + endif + endif + + do i=Isq,Ieq+1 + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) + dpa(i,j) = G_e*dz(i)*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) + endif + enddo + enddo ! end loops on j + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec + do I=Isq,Ieq + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + dz_x(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i+1,j,K)) + + ! Pressure + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) + enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + enddo + enddo + + if (use_stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & + rho_ref=rho_ref_mks) + endif + else + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, & + scale=rho_scale) + else + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + endif + endif + + do I=Isq,Ieq + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + + ! Use Boole's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo + enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then ; do J=Jsq,Jeq + do i=HI%isc,HI%iec + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + dz_y(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i,j+1,K)) + + ! Pressure + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) + enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) + enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + enddo + enddo + + if (use_stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + endif + else + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + endif + endif + + do i=HI%isc,HI%iec + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Boole's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo + enddo ; endif + +end subroutine int_density_dz_generic_plm + + +!> Compute pressure gradient force integrals for layer "k" and the case where T and S +!! are parabolic profiles +subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, & + dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + integer, intent(in) :: k !< Layer index to calculate integrals for + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_t !< Salinity at the cell top [ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate + !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] + real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the y grid spacing [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + +! This subroutine calculates (by numerical quadrature) integrals of +! pressure anomalies across layers, which are required for calculating the +! finite-volume form pressure accelerations in a Boussinesq model. The one +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! It is assumed that the salinity and temperature profiles are parabolic in the +! vertical. The top and bottom values within each layer are provided and +! a parabolic interpolation is used to compute intermediate values. + + ! Local variables + real :: T5(5) ! Temperatures along a line of subgrid locations [degC] + real :: S5(5) ! Salinities along a line of subgrid locations [ppt] + real :: T25(5) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS5(5) ! SGS temperature-salinity covariance along a line of subgrid locations [degC ppt] + real :: S25(5) ! SGS salinity variance along a line of subgrid locations [ppt2] + real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] + real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] + real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: dz ! Layer thicknesses at tracer points [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [degC] + real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [ppt] + real :: s6 ! PPM curvature coefficient for S [ppt] + real :: t6 ! PPM curvature coefficient for T [degC] + real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T + real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S + real :: hWght ! A topographically limited thicknes weight [Z ~> m] + real :: hL, hR ! Thicknesses to the left and right [Z ~> m] + real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n + logical :: use_PPM ! If false, assume zero curvature in reconstruction, i.e. PLM + logical :: use_stanley_eos ! True is SGS variance fields exist in tv. + logical :: use_varT, use_varS, use_covarTS + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + + ! In event PPM calculation is bypassed with use_PPM=False + s6 = 0. + t6 = 0. + use_PPM = .true. ! This is a place-holder to allow later re-use of this function + + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) + use_stanley_eos = use_varT .or. use_covarTS .or. use_varS + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (use_PPM) then + ! Curvature coefficient of the parabolas + s6 = 3.0 * ( 2.0*tv%S(i,j,k) - ( S_t(i,j,k) + S_b(i,j,k) ) ) + t6 = 3.0 * ( 2.0*tv%T(i,j,k) - ( T_t(i,j,k) + T_b(i,j,k) ) ) + endif + dz = e(i,j,K) - e(i,j,K+1) + do n=1,5 + p5(n) = -GxRho*(e(i,j,K) - 0.25*real(n-1)*dz) + ! Salinity and temperature points are reconstructed with PPM + S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) + enddo + if (use_stanley_eos) then + if (use_varT) T25(:) = tv%varT(i,j,k) + if (use_covarTS) TS5(:) = tv%covarTS(i,j,k) + if (use_varS) S25(:) = tv%varS(i,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & + 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + dpa(i,j) = G_e*dz*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + endif + enddo ; enddo ! end loops on j and i + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i+1,j,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i+1,j,k) + (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + Sml = tv%S(i,j,k); Smr = tv%S(i+1,j,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr + + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr + + ! Pressure + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + p5(1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i+1,j,K)) + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & + 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i,j+1,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i,j+1,k)+ (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + Sml = tv%S(i,j,k); Smr = tv%S(i,j+1,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr + + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr + + ! Pressure + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + p5(1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i,j+1,K)) + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & + 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Boole's rule to integrate the bottom pressure anomaly values in y. + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + + enddo ; enddo ; endif + +end subroutine int_density_dz_generic_ppm + +!> Calls the appropriate subroutine to calculate analytical and nearly-analytical +!! integrals in pressure across layers of geopotential anomalies, which are +!! required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the +!! use of Boole's rule to do the horizontal integrals, and from a truncation in the +!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but this reduces the effects of roundoff. + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the + !! geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + + if (EOS_quadrature(EOS)) then + call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + else + call analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + endif + +end subroutine int_specific_vol_dp + + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, dza, & + intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature of the layer [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity of the layer [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but alpha_ref alters the effects of roundoff, and + !! answers do change. + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dza !< The change in the geopotential anomaly + !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + +! This subroutine calculates analytical and nearly-analytical integrals in +! pressure across layers of geopotential anomalies, which are required for +! calculating the finite-volume form pressure accelerations in a non-Boussinesq +! model. There are essentially no free assumptions, apart from the use of +! Boole's rule to do the horizontal integrals, and from a truncation in the +! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. + + ! Local variables + real :: T5(5) ! Temperatures at five quadrature points [degC] + real :: S5(5) ! Salinities at five quadrature points [ppt] + real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa if necessary [Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] + real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif + + SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = US%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref * US%kg_m3_to_R + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "bathyP must be present if useMassWghtInterp is present and true.") + if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=jsh,jeh ; do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) + enddo + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i+1,j)) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - RL2_T2_to_Pa * 0.25*dp + enddo + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i,j+1)) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) + enddo + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in y. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_pcm + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & + dP_neglect, bathyP, HI, EOS, US, dza, & + intp_dza, intx_dza, inty_dza, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T_t !< Potential temperature at the top of the layer [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S_t !< Salinity at the top the layer [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S_b !< Salinity at the bottom the layer [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but alpha_ref alters the effects of roundoff, and + !! answers do change. + real, intent(in) :: dP_neglect ! Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dza !< The change in the geopotential anomaly + !! across the layer [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + +! This subroutine calculates analytical and nearly-analytical integrals in +! pressure across layers of geopotential anomalies, which are required for +! calculating the finite-volume form pressure accelerations in a non-Boussinesq +! model. There are essentially no free assumptions, apart from the use of +! Boole's rule to do the horizontal integrals, and from a truncation in the +! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. + + real :: T5(5) ! Temperatures at five quadrature points [degC] + real :: S5(5) ! Salinities at five quadrature points [ppt] + real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa as necessary [Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: T15(15) ! Temperatures at fifteen interior quadrature points [degC] + real :: S15(15) ! Salinities at fifteen interior quadrature points [ppt] + real :: p15(15) ! Pressures at fifteen quadrature points, scaled back to Pa as necessary [Pa] + real :: a15(15) ! Specific volumes at fifteen quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] + real :: T_top, T_bot, S_top, S_bot, P_top, P_bot + + real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] + real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. + logical :: do_massWeight ! Indicates whether to do mass weighting. + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = .false. + if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp + + SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = US%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref * US%kg_m3_to_R + + do n = 1, 5 ! Note that these are reversed from int_density_dz. + wt_t(n) = 0.25 * real(n-1) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1; do i=Isq,Ieq+1 + dp = p_b(i,j) - p_t(i,j) + do n=1,5 ! T, S and p are linearly interpolated in the vertical. + p5(n) = RL2_T2_to_Pa * (wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j)) + S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) + T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + enddo + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. Note: To work in terrain following coordinates we could + ! offset this distance by the layer thickness to replicate other models. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_plm + + +!> Find the depth at which the reconstructed pressure matches P_tgt +subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & + rho_ref, G_e, EOS, US, P_b, z_out, z_tol) + real, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, intent(in) :: S_t !< Salinity at the cell top [ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m] (Boussinesq ????) + real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m] + real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative + !! to g*rho_ref*z_t [R L2 T-2 ~> Pa] + real, intent(in) :: P_tgt !< Target pressure at height z_out, relative + !! to g*rho_ref*z_out [R L2 T-2 ~> Pa] + real, intent(in) :: rho_ref !< Reference density with which calculation + !! are anomalous to [R ~> kg m-3] + real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> Pa] + real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m] + real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] + + ! Local variables + real :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] + real :: F_guess, F_l, F_r ! Fractional positions [nondim] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] + real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] + character(len=240) :: msg + + GxRho = G_e * rho_ref + + ! Anomalous pressure difference across whole cell + dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) + + P_b = P_t + dp ! Anomalous pressure at bottom of cell + + if (P_tgt <= P_t ) then + z_out = z_t + return + endif + + if (P_tgt >= P_b) then + z_out = z_b + return + endif + + F_l = 0. + Pa_left = P_t - P_tgt ! Pa_left < 0 + F_r = 1. + Pa_right = P_b - P_tgt ! Pa_right > 0 + Pa_tol = GxRho * 1.0e-5*US%m_to_Z + if (present(z_tol)) Pa_tol = GxRho * z_tol + + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) + Pa = Pa_right - Pa_left ! To get into iterative loop + do while ( abs(Pa) > Pa_tol ) + + z_out = z_t + ( z_b - z_t ) * F_guess + Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) + + if (PaPa_right) then + write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt + call MOM_error(FATAL, 'find_depth_of_pressure_in_cell out of bounds positive: /n'//msg) + elseif (Pa>0.) then + Pa_right = Pa + F_r = F_guess + else ! Pa == 0 + return + endif + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) + + enddo + +end subroutine find_depth_of_pressure_in_cell + + +!> Returns change in anomalous pressure change from top to non-dimensional +!! position pos between z_t and z_b +real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) + real, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, intent(in) :: S_t !< Salinity at the cell top [ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] + real, intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted out to + !! reduce the magnitude of each of the integrals. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] + type(EOS_type), pointer :: EOS !< Equation of state structure + real :: fract_dp_at_pos !< The change in pressure from the layer top to + !! fractional position pos [R L2 T-2 ~> Pa] + ! Local variables + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: dz ! Distance from the layer top [Z ~> m] + real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] + real :: rho_ave ! Average density [R ~> kg m-3] + real, dimension(5) :: T5 ! Temperatures at quadrature points [degC] + real, dimension(5) :: S5 ! Salinities at quadrature points [ppt] + real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] + real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] + integer :: n + + do n=1,5 + ! Evaluate density at five quadrature points + bottom_weight = 0.25*real(n-1) * pos + top_weight = 1.0 - bottom_weight + ! Salinity and temperature points are linearly interpolated + S5(n) = top_weight * S_t + bottom_weight * S_b + T5(n) = top_weight * T_t + bottom_weight * T_b + p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) + enddo + call calculate_density(T5, S5, p5, rho5, EOS) + rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref + + ! Use Boole's rule to estimate the average density + rho_ave = C1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3)) + + dz = ( z_t - z_b ) * pos + frac_dp_at_pos = G_e * dz * rho_ave +end function frac_dp_at_pos + +end module MOM_density_integrals + +!> \namespace mom_density_integrals +!! diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 276c3c330f..64a9c18b97 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -160,10 +160,16 @@ module MOM_dynamics_split_RK2 integer :: id_umo_2d = -1, id_vmo_2d = -1 integer :: id_PFu = -1, id_PFv = -1 integer :: id_CAu = -1, id_CAv = -1 + ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 + ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 + integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 + ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 + integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 !>@} type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the @@ -318,6 +324,19 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s u_av, & ! The zonal velocity time-averaged over a time step [L T-1 ~> m s-1]. v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + + ! real, allocatable, dimension(:,:,:) :: & + ! hf_PFu, hf_PFv, & ! Pressure force accel. x fract. thickness [L T-2 ~> m s-2]. + ! hf_CAu, hf_CAv, & ! Coriolis force accel. x fract. thickness [L T-2 ~> m s-2]. + ! hf_u_BT_accel, hf_v_BT_accel ! barotropic correction accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + + real, allocatable, dimension(:,:) :: & + hf_PFu_2d, hf_PFv_2d, & ! Depth integeral of hf_PFu, hf_PFv [L T-2 ~> m s-2]. + hf_CAu_2d, hf_CAv_2d, & ! Depth integeral of hf_CAu, hf_CAv [L T-2 ~> m s-2]. + hf_u_BT_accel_2d, hf_v_BT_accel_2d ! Depth integeral of hf_u_BT_accel, hf_v_BT_accel + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf @@ -532,7 +551,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! This is the predictor step call to btstep. call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, & u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, & - G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, & + G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, ADp=CS%ADp, & OBC=CS%OBC, BT_cont=CS%BT_cont, eta_PF_start=eta_PF_start, & taux_bot=taux_bot, tauy_bot=tauy_bot, & uh0=uh_ptr, vh0=vh_ptr, u_uh0=u_ptr, v_vh0=v_ptr) @@ -682,7 +701,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc_CSp, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp) + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + ADp=CS%ADp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") @@ -733,8 +753,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, & CS%eta_PF, u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, & eta_pred, CS%uhbt, CS%vhbt, G, GV, US, CS%barotropic_CSp, & - CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, OBC=CS%OBC, & - BT_cont = CS%BT_cont, eta_PF_start=eta_PF_start, & + CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, ADp=CS%ADp, & + OBC=CS%OBC, BT_cont = CS%BT_cont, eta_PF_start=eta_PF_start, & taux_bot=taux_bot, tauy_bot=tauy_bot, & uh0=uh_ptr, vh0=vh_ptr, u_uh0=u_ptr, v_vh0=v_ptr) do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo @@ -860,6 +880,109 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_PFu > 0) then + ! allocate(hf_PFu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_PFu(I,j,k) = CS%PFu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_PFu, hf_PFu, CS%diag) + !endif + !if (CS%id_hf_PFv > 0) then + ! allocate(hf_PFv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_PFv(i,J,k) = CS%PFv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_PFv, hf_PFv, CS%diag) + !endif + if (CS%id_hf_PFu_2d > 0) then + allocate(hf_PFu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_PFu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_PFu_2d(I,j) = hf_PFu_2d(I,j) + CS%PFu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_PFu_2d, hf_PFu_2d, CS%diag) + deallocate(hf_PFu_2d) + endif + if (CS%id_hf_PFv_2d > 0) then + allocate(hf_PFv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_PFv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_PFv_2d(i,J) = hf_PFv_2d(i,J) + CS%PFv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_PFv_2d, hf_PFv_2d, CS%diag) + deallocate(hf_PFv_2d) + endif + + !if (CS%id_hf_CAu > 0) then + ! allocate(hf_CAu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_CAu(I,j,k) = CS%CAu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_CAu, hf_CAu, CS%diag) + !endif + !if (CS%id_hf_CAv > 0) then + ! allocate(hf_CAv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_CAv(i,J,k) = CS%CAv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_CAv, hf_CAv, CS%diag) + !endif + if (CS%id_hf_CAu_2d > 0) then + allocate(hf_CAu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_CAu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_CAu_2d(I,j) = hf_CAu_2d(I,j) + CS%CAu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_CAu_2d, hf_CAu_2d, CS%diag) + deallocate(hf_CAu_2d) + endif + if (CS%id_hf_CAv_2d > 0) then + allocate(hf_CAv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_CAv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_CAv_2d(i,J) = hf_CAv_2d(i,J) + CS%CAv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_CAv_2d, hf_CAv_2d, CS%diag) + deallocate(hf_CAv_2d) + endif + + !if (CS%id_hf_u_BT_accel > 0) then + ! allocate(hf_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_u_BT_accel(I,j,k) = CS%u_accel_bt(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_u_BT_accel, hf_u_BT_accel, CS%diag) + !endif + !if (CS%id_hf_v_BT_accel > 0) then + ! allocate(hf_v_BT_accel(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_v_BT_accel(i,J,k) = CS%v_accel_bt(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_v_BT_accel, hf_v_BT_accel, CS%diag) + !endif + if (CS%id_hf_u_BT_accel_2d > 0) then + allocate(hf_u_BT_accel_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_u_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_u_BT_accel_2d(I,j) = hf_u_BT_accel_2d(I,j) + CS%u_accel_bt(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_u_BT_accel_2d, hf_u_BT_accel_2d, CS%diag) + deallocate(hf_u_BT_accel_2d) + endif + if (CS%id_hf_v_BT_accel_2d > 0) then + allocate(hf_v_BT_accel_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_v_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_v_BT_accel_2d(i,J) = hf_v_BT_accel_2d(i,J) + CS%v_accel_bt(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_v_BT_accel_2d, hf_v_BT_accel_2d, CS%diag) + deallocate(hf_v_BT_accel_2d) + endif + if (CS%debug) then call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -1110,7 +1233,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, US, param_file, diag, CS%hor_visc_CSp, MEKE) + call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE, ADp=CS%ADp) 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, & @@ -1232,6 +1355,46 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vav = register_diag_field('ocean_model', 'vav', diag%axesCvL, Time, & @@ -1242,6 +1405,26 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_v_BT_accel = register_diag_field('ocean_model', 'v_BT_accel', diag%axesCvL, Time, & 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index f6c8b44986..8844c65f40 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -210,10 +210,10 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, default=0.0, do_not_log=.true.) call log_version(param_file, mod_nm, version, & "Parameters providing information about the lateral grid.", & - log_to_all=.true., layout=.true.) - + log_to_all=.true., layout=.true., all_default=(G%Z_ref==0.0)) call get_param(param_file, mod_nm, "NIBLOCK", niblock, "The number of blocks "// & "in the x-direction on each processor (for openmp).", default=1, & diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index fc775d938f..b8cf161148 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -9,7 +9,7 @@ module MOM_interface_heights 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 : int_specific_vol_dp +use MOM_density_integrals, only : int_specific_vol_dp implicit none ; private @@ -109,7 +109,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !$OMP do do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), & - 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo) + 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) enddo !$OMP do do j=jsv,jev @@ -214,7 +214,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !$OMP do do k = 1, nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), 0.0, & - G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo) + G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) enddo !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index fa60fb821d..c134366cd0 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -7,7 +7,9 @@ module MOM_isopycnal_slopes 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 : int_specific_vol_dp, calculate_density_derivs +use MOM_EOS, only : calculate_density_derivs +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S implicit none ; private @@ -24,7 +26,7 @@ module MOM_isopycnal_slopes !> Calculate isopycnal slopes, and optionally return N2 used in calculation. subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & - slope_x, slope_y, N2_u, N2_v, halo) !, eta_to_m) + slope_x, slope_y, N2_u, N2_v, halo, OBC) !, eta_to_m) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -44,6 +46,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at !! interfaces between u-points [T-2 ~> s-2] integer, optional, intent(in) :: halo !< Halo width over which to compute + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! real, optional, intent(in) :: eta_to_m !< The conversion factor from the units ! (This argument has been tested but for now serves no purpose.) !! of eta to m; US%Z_to_m by default. @@ -102,6 +105,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & integer, dimension(2) :: EOSdom_u, EOSdom_v ! Domains for the equation of state calculations at u and v points integer :: is, ie, js, je, nz, IsdB integer :: i, j, k + integer :: l_seg + logical :: local_open_u_BC, local_open_v_BC if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -118,6 +123,13 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & L_to_Z = 1.0 / Z_to_L dz_neglect = GV%H_subroundoff * H_to_Z + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + use_EOS = associated(tv%eqn_of_state) present_N2_u = PRESENT(N2_u) @@ -167,11 +179,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & - !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u) & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u,local_open_u_BC, & + !$OMP OBC) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,Slope,slope2_Ratio) + !$OMP drdx,mag_grad2,Slope,slope2_Ratio,l_seg) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -247,6 +260,22 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & else ! With .not.use_EOS, the layers are constant density. slope_x(I,j,K) = (Z_to_L*(e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) endif + if (local_open_u_BC) then + l_seg = OBC%segnum_u(I,j) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope_x(I,j,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then +! slope_x(I+1,j,K) = 0. +! else +! slope_x(I-1,j,K) = 0. +! endif + endif + endif + slope_x(I,j,K) = slope_x(I,j,k) * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + endif enddo ! I enddo ; enddo ! end of j-loop @@ -256,11 +285,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & - !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,EOSdom_v) & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,EOSdom_v, & + !$OMP local_open_v_BC,OBC) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,Slope,slope2_Ratio) + !$OMP drdy,mag_grad2,Slope,slope2_Ratio,l_seg) do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 @@ -333,6 +363,22 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & else ! With .not.use_EOS, the layers are constant density. slope_y(i,J,K) = (Z_to_L*(e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) endif + if (local_open_v_BC) then + l_seg = OBC%segnum_v(i,J) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope_y(i,J,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then +! slope_y(i,J+1,K) = 0. +! else +! slope_y(i,J-1,K) = 0. +! endif + endif + endif + slope_y(i,J,K) = slope_y(i,J,k) * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + endif enddo ! i enddo ; enddo ! end of j-loop diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index bf3d24a790..ab4a59db89 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -9,7 +9,7 @@ module MOM_open_boundary use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector -use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE +use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE, CORNER use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : NOTE use MOM_file_parser, only : get_param, log_version, param_file_type, log_param @@ -56,12 +56,17 @@ module MOM_open_boundary public segment_tracer_registry_end public register_segment_tracer public register_temp_salt_segments +public register_obgc_segments public fill_temp_salt_segments +public fill_obgc_segments +public set_obgc_segments_props public open_boundary_register_restarts public update_segment_tracer_reservoirs public update_OBC_ramp public rotate_OBC_config public rotate_OBC_init +public initialize_segment_data +public setup_OBC_tracer_reservoirs integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary @@ -78,7 +83,8 @@ module MOM_open_boundary type, public :: OBC_segment_data_type integer :: fid !< handle from FMS associated with segment data on disk integer :: fid_dz !< handle from FMS associated with segment thicknesses on disk - character(len=8) :: name !< a name identifier for the segment data + character(len=32) :: name !< a name identifier for the segment data + character(len=8) :: genre !< a family identifier for the segment data real, dimension(:,:,:), allocatable :: buffer_src !< buffer for segment data located at cell faces !! and on the original vertical grid integer :: nk_src !< Number of vertical levels in the source data @@ -268,7 +274,7 @@ module MOM_open_boundary real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of !! characteristics) in units of grid points per timestep [nondim]. logical :: OBC_pe !< Is there an open boundary on this tile? - type(remapping_CS), pointer :: remap_CS !< ALE remapping control structure for segments only + type(remapping_CS), pointer :: remap_CS=> NULL() !< ALE remapping control structure for segments only type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries real, pointer, dimension(:,:,:) :: & rx_normal => NULL(), & !< Array storage for normal phase speed for EW radiation OBCs in units of @@ -314,8 +320,16 @@ module MOM_open_boundary !! When locked=.true.,no more boundaries can be registered. end type OBC_registry_type +!> Type to carry OBC information needed for setting segments for OBGC tracers +type, private :: external_tracers_segments_props + type(external_tracers_segments_props), pointer :: next => NULL() + character(len=128) :: tracer_name + character(len=128) :: tracer_src_file + character(len=128) :: tracer_src_field +end type external_tracers_segments_props +type(external_tracers_segments_props), pointer, save :: obgc_segments_props => NULL() !< Linked-list of obgc tracers properties +integer, save :: num_obgc_tracers = 0 !< Keeps the total number of obgc tracers integer :: id_clock_pass !< A CPU time clock - character(len=40) :: mdl = "MOM_open_boundary" !< This module's name. ! This include declares and sets the variable "version". #include "version_variable.h" @@ -341,6 +355,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] + character(len=128) :: inputdir + logical :: answers_2018, default_2018_answers + logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + character(len=32) :: remappingScheme + allocate(OBC) call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & @@ -445,9 +464,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.) ! Allocate everything - ! Note the 0-segment is needed when %segnum_u/v(:,:) = 0 - allocate(OBC%segment(0:OBC%number_of_segments)) - do l=0,OBC%number_of_segments + allocate(OBC%segment(1:OBC%number_of_segments)) + do l=1,OBC%number_of_segments OBC%segment(l)%Flather = .false. OBC%segment(l)%radiation = .false. OBC%segment(l)%radiation_tan = .false. @@ -498,7 +516,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) enddo ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & - call initialize_segment_data(G, OBC, param_file) + ! call initialize_segment_data(G, OBC, param_file) if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & @@ -541,6 +559,39 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo + call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & + "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(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & + "If true, read external OBC data on the supergrid.", & + default=.false.) + call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& + "round off.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.false.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + + allocate(OBC%remap_CS) + call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & + check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) + endif ! OBC%number_of_segments > 0 ! Safety check @@ -565,11 +616,11 @@ end subroutine open_boundary_config subroutine initialize_segment_data(G, OBC, PF) use mpp_mod, only : mpp_pe, mpp_set_current_pelist, mpp_get_current_pelist,mpp_npes - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle - integer :: n,m,num_fields + integer :: n,m,num_fields,mm character(len=256) :: segstr, filename character(len=20) :: segnam, suffix character(len=32) :: varnam, fieldname @@ -577,10 +628,7 @@ subroutine initialize_segment_data(G, OBC, PF) character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - character(len=32) :: remappingScheme character(len=256) :: mesg ! Message for error messages. - logical :: check_reconstruction, check_remapping, force_bounds_in_subcell - logical :: answers_2018, default_2018_answers integer, dimension(4) :: siz,siz2 integer :: is, ie, js, je integer :: isd, ied, jsd, jed @@ -588,6 +636,7 @@ subroutine initialize_segment_data(G, OBC, PF) integer, dimension(:), allocatable :: saved_pelist integer :: current_pe integer, dimension(1) :: single_pelist + type(external_tracers_segments_props), pointer :: obgc_segments_props_list =>NULL() !will be able to dynamically switch between sub-sampling refined grid data or model grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -600,39 +649,6 @@ subroutine initialize_segment_data(G, OBC, PF) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - call get_param(PF, mdl, "REMAPPING_SCHEME", remappingScheme, & - "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 "//& - "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 "//& - "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 "//& - "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.", & - default=.false.) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - - allocate(OBC%remap_CS) - call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) - if (OBC%user_BCs_set_globally) return ! Try this here just for the documentation. It is repeated below. @@ -673,8 +689,9 @@ subroutine initialize_segment_data(G, OBC, PF) cycle ! cycle to next segment endif - allocate(segment%field(num_fields)) - segment%num_fields = num_fields + !There are num_obgc_tracers obgc tracers are there that are not listed in param file + segment%num_fields = num_fields +num_obgc_tracers + allocate(segment%field(segment%num_fields)) segment%temp_segment_data_exists=.false. segment%salt_segment_data_exists=.false. @@ -687,8 +704,22 @@ subroutine initialize_segment_data(G, OBC, PF) IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - do m=1,num_fields - call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + obgc_segments_props_list => obgc_segments_props !Get a pointer to the saved type + do m=1,segment%num_fields + if(m .le. num_fields) then + call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + else + segment%field(m)%genre='obgc' + call get_obgc_segments_props(obgc_segments_props_list,fields(m),filename,fieldname) + do mm=1,num_fields + if(trim(fields(m))==trim(fields(mm))) then + if (is_root_pe()) & + call MOM_error(FATAL,"MOM_open_boundary:initialize_segment_data(): obgc tracer " //trim(fields(m))// & +" appears in OBC_SEGMENT_XXX_DATA string in MOM6 param file. This is not supported!") + endif + enddo + endif + if (trim(filename) /= 'none') then OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file OBC%needs_IO_for_data = .true. ! At least one segment is using I/O for OBC data @@ -1343,7 +1374,7 @@ end function interpret_int_expr end subroutine parse_segment_str !> Parse an OBC_SEGMENT_%%%_DATA string - subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fields, num_fields, debug ) + subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fields, num_fields, debug, has_var ) character(len=*), intent(in) :: segment_str !< A string in form of !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." character(len=*), optional, intent(in) :: var !< The name of the variable for which parameters are needed @@ -1355,14 +1386,16 @@ subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fi optional, intent(out) :: fields !< List of fieldnames for each segment integer, optional, intent(out) :: num_fields !< The number of fields in the segment data logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages + logical, optional, intent(out) :: has_var !< .true. if var is found in segment_str ! Local variables character(len=128) :: word1, word2, word3, method integer :: lword, nfields, n, m - logical :: continue,dbg + logical :: continue,dbg,has character(len=32), dimension(MAX_OBC_FIELDS) :: flds nfields=0 continue=.true. + has=.false. dbg=.false. if (PRESENT(debug)) dbg=debug @@ -1390,11 +1423,13 @@ subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fi do n=1,nfields if (trim(var)==trim(flds(n))) then m=n + has=.true. exit endif enddo + if (PRESENT(has_var)) has_var=has if (m==0) then - call abort() + return ! Why call abort() ? endif ! Process first word which will start with the fieldname @@ -1476,8 +1511,8 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) else OBC%tracer_y_reservoirs_used(2) = .true. endif - endif - endif + endif + endif enddo ! Alternately, set first two to true if use_temperature is true if (use_temperature) then @@ -1489,6 +1524,23 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) OBC%tracer_y_reservoirs_used(2) = .true. endif endif + !Add reservoirs for external/obgc tracers + !There is a diconnect in the above logic between tracer index and reservoir index. + !It arbitarily assigns reservoir indexes 1&2 to tracers T&S, + !so we need to start from 3 for the rest of tracers, hence the m+2 in the following. + !num_fields is the number of vars in segstr (6 of them now, U,V,SSH,TEMP,SALT,dye) + !but OBC%tracer_x_reservoirs_used is allocated to size Reg%ntr, which is the total number of tracers + !(t,s,dye,obgc1,obcg2,obgc3,... 6 of them by chance) + do m=1,num_obgc_tracers + !This logic assumes all external tarcers need a reservoir + !The segments for tracers are not initialized yet (that happens later in initialize_segment_data()) + !so we cannot query to determine if this tracer needs a reservoir. + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(m+2) = .true. + else + OBC%tracer_y_reservoirs_used(m+2) = .true. + endif + enddo enddo return @@ -1590,7 +1642,7 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) ! Local variables real :: vel2_rescale ! A rescaling factor for squared velocities from the representation in ! a restart file to the internal representation in this run. - integer :: i, j, k, isd, ied, jsd, jed, nz + integer :: i, j, k, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -1598,6 +1650,16 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) if (.not.associated(OBC)) return id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) + if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & + To_All+Scalar_Pair) + if (OBC%oblique_BCs_exist_globally) call pass_vector(OBC%rx_oblique, OBC%ry_oblique, G%Domain, & + To_All+Scalar_Pair) + if (associated(OBC%cff_normal)) call pass_var(OBC%cff_normal, G%Domain, position=CORNER) + if (associated(OBC%tres_x) .or. associated(OBC%tres_y)) then + do m=1,OBC%ntr + call pass_vector(OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%Domain, To_All+Scalar_Pair) + enddo + endif ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to @@ -1849,8 +1911,8 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) end subroutine open_boundary_impose_land_mask !> Make sure the OBC tracer reservoirs are initialized. -subroutine setup_OBC_tracer_reservoirs(G, OBC) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure +subroutine setup_OBC_tracer_reservoirs(Gke, OBC) + integer, intent(in) :: Gke !< Ocean grid ke type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables type(OBC_segment_type), pointer :: segment => NULL() @@ -1863,7 +1925,7 @@ subroutine setup_OBC_tracer_reservoirs(G, OBC) I = segment%HI%IsdB do m=1,OBC%ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,G%ke + do k=1,Gke do j=segment%HI%jsd,segment%HI%jed OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%t(i,j,k) enddo @@ -1874,7 +1936,7 @@ subroutine setup_OBC_tracer_reservoirs(G, OBC) J = segment%HI%JsdB do m=1,OBC%ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,G%ke + do k=1,Gke do i=segment%HI%isd,segment%HI%ied OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%t(i,J,k) enddo @@ -3269,6 +3331,22 @@ function lookup_seg_field(OBC_seg,field) end function lookup_seg_field +!> Return the tracer index from its name +function get_tracer_index(OBC_seg,tr_name) + type(OBC_segment_type), pointer :: OBC_seg !< OBC segment + character(len=*), intent(in) :: tr_name !< The field name + integer :: get_tracer_index, it + get_tracer_index=-1 + it=1 + do while(associated(OBC_seg%tr_Reg%Tr(it)%t)) + if (trim(OBC_seg%tr_Reg%Tr(it)%name) == trim(tr_name)) then + get_tracer_index=it + exit + endif + it=it+1 + enddo + return +end function get_tracer_index !> Allocate segment data fields subroutine allocate_OBC_segment_data(OBC, segment) @@ -3511,7 +3589,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) type(time_type), intent(in) :: Time !< Model time ! Local variables integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed - integer :: IsdB, IedB, JsdB, JedB, n, m, nz + integer :: IsdB, IedB, JsdB, JedB, n, m, nz, nt, it character(len=40) :: mdl = "set_OBC_segment_data" ! This subroutine's name. character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path type(OBC_segment_type), pointer :: segment => NULL() @@ -3540,6 +3618,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (.not. associated(OBC)) return + call MOM_error(NOTE,"update_OBC_segment_data: called! ") do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -3937,7 +4016,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) G%dyCu(I,j) normal_trans_bt(I,j) = normal_trans_bt(I,j) + segment%normal_trans(I,j,k) enddo - segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) / (max(segment%Htot(I,j),1.e-12) * G%dyCu(I,j)) + segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) & + / (max(segment%Htot(I,j), 1.e-12 * GV%m_to_H) * G%dyCu(I,j)) if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:) enddo elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then @@ -3950,7 +4030,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) G%dxCv(i,J) normal_trans_bt(i,J) = normal_trans_bt(i,J) + segment%normal_trans(i,J,k) enddo - segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) / (max(segment%Htot(i,J),1.e-12) * G%dxCv(i,J)) + segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) & + / (max(segment%Htot(i,J), 1.e-12 * GV%m_to_H) * G%dxCv(i,J)) if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) enddo elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & @@ -4018,13 +4099,14 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (OBC%ramp) then do j=js_obc2,je_obc do i=is_obc2,ie_obc - segment%eta(i,j) = OBC%ramp_value * segment%field(m)%buffer_dst(i,j,1) + segment%eta(i,j) = GV%m_to_H * OBC%ramp_value & + * segment%field(m)%buffer_dst(i,j,1) enddo enddo else do j=js_obc2,je_obc do i=is_obc2,ie_obc - segment%eta(i,j) = segment%field(m)%buffer_dst(i,j,1) + segment%eta(i,j) = GV%m_to_H * segment%field(m)%buffer_dst(i,j,1) enddo enddo endif @@ -4060,6 +4142,25 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) else segment%tr_Reg%Tr(2)%OBC_inflow_conc = segment%field(m)%value endif + elseif (trim(segment%field(m)%genre) == 'obgc') then + nt=get_tracer_index(segment,trim(segment%field(m)%name)) + if(nt .lt. 0) then + call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer "//trim(segment%field(m)%name)) + endif + if (associated(segment%field(m)%buffer_dst)) then + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) + enddo ; enddo ; enddo + if (.not. segment%tr_Reg%Tr(nt)%is_initialized) then + !if the tracer reservoir has not yet been initialized, then set to external value. + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(nt)%tres(i,j,k) = segment%tr_Reg%Tr(nt)%t(i,j,k) + enddo ; enddo ; enddo + segment%tr_Reg%Tr(nt)%is_initialized=.true. + endif + else + segment%tr_Reg%Tr(nt)%OBC_inflow_conc = segment%field(m)%value + endif endif enddo ! end field loop @@ -4336,6 +4437,110 @@ subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) end subroutine register_temp_salt_segments +!> Sets the OBC properties of external obgc tracers, such as their source file and field name +subroutine set_obgc_segments_props(tr_name,obc_src_file_name,obc_src_field_name) + character(len=*), intent(in) :: tr_name !< Tracer name + character(len=*), intent(in) :: obc_src_file_name !< OBC source file name + character(len=*), intent(in) :: obc_src_field_name !< name of the field in the source file + + type(external_tracers_segments_props),pointer :: node_ptr => NULL() + allocate(node_ptr) + node_ptr%tracer_name = trim(tr_name) + node_ptr%tracer_src_file = trim(obc_src_file_name) + node_ptr%tracer_src_field = trim(obc_src_field_name) + !Reversed Linked List implementation! Make this new node to be the head of the list. + node_ptr%next => obgc_segments_props + obgc_segments_props => node_ptr + num_obgc_tracers = num_obgc_tracers+1 +end subroutine set_obgc_segments_props + +!> Get the OBC properties of external obgc tracers, such as their source file and field name +subroutine get_obgc_segments_props(node, tr_name,obc_src_file_name,obc_src_field_name) + type(external_tracers_segments_props),pointer :: node + character(len=*), intent(out) :: tr_name !< Tracer name + character(len=*), intent(out) :: obc_src_file_name !< OBC source file name + character(len=*), intent(out) :: obc_src_field_name !< name of the field in the source file + + tr_name=trim(node%tracer_name) + obc_src_file_name=trim(node%tracer_src_file) + obc_src_field_name=trim(node%tracer_src_field) + !pop the head. + node => node%next + +end subroutine get_obgc_segments_props + +subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + character(len=*), intent(in) :: tr_name!< Tracer name +! Local variables + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf + integer :: i, j, k, n + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + type(tracer_type), pointer :: tr_ptr => NULL() + + if (.not. associated(OBC)) return + + do n=1, OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + call tracer_name_lookup(tr_Reg, tr_ptr, tr_name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_array=.True.) + enddo + +end subroutine register_obgc_segments + +subroutine fill_obgc_segments(G, OBC, tr_ptr, tr_name) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(:,:,:), pointer :: tr_ptr !< Pointer to tracer field + character(len=*), intent(in) :: tr_name!< Tracer name +! Local variables + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz, nt + integer :: i, j, k + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + + if (.not. associated(OBC)) return + call pass_var(tr_ptr, G%Domain) + nz = G%ke + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + nt=get_tracer_index(segment,tr_name) + if(nt .lt. 0) then + call MOM_error(FATAL,"fill_obgc_segments: Did not find tracer "// tr_name) + endif + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + ! Fill with Tracer values + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + if (segment%direction == OBC_DIRECTION_W) then + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i+1,j,k) + else + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i,j,k) + endif + enddo ; enddo + else + J=segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + if (segment%direction == OBC_DIRECTION_S) then + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j+1,k) + else + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j,k) + endif + enddo ; enddo + endif + segment%tr_Reg%Tr(nt)%tres(:,:,:) = segment%tr_Reg%Tr(nt)%t(:,:,:) + enddo + !call setup_OBC_tracer_reservoirs(G%ke, OBC) !This will redo the T&S +end subroutine fill_obgc_segments + subroutine fill_temp_salt_segments(G, OBC, tv) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure @@ -4392,7 +4597,7 @@ subroutine fill_temp_salt_segments(G, OBC, tv) segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) enddo - call setup_OBC_tracer_reservoirs(G, OBC) + !call setup_OBC_tracer_reservoirs(G%ke, OBC) end subroutine fill_temp_salt_segments !> Find the region outside of all open boundary segments and @@ -4407,6 +4612,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n integer :: i, j + integer :: l_seg logical :: fatal_error = .False. real :: min_depth integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 @@ -4448,38 +4654,50 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then if (color(i,j) == 0.0) color(i,j) = cout if (color(i+1,j) == 0.0) color(i+1,j) = cin - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then if (color(i,j) == 0.0) color(i,j) = cin if (color(i+1,j) == 0.0) color(i+1,j) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then if (color(i,j) == 0.0) color(i,j) = cout if (color(i,j+1) == 0.0) color(i,j+1) = cin - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then if (color(i,j) == 0.0) color(i,j) = cin if (color(i,j+1) == 0.0) color(i,j+1) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i,j+1) == 0.0) color2(i,j+1) = cin - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i,j+1) == 0.0) color2(i,j+1) = cout endif enddo ; enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i+1,j) == 0.0) color2(i+1,j) = cin - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i+1,j) == 0.0) color2(i+1,j) = cout endif @@ -4639,7 +4857,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! Local variables type(vardesc) :: vd(2) integer :: m, n - character(len=100) :: mesg + character(len=256) :: mesg,longname type(OBC_segment_type), pointer :: segment=>NULL() if (.not. associated(OBC)) & @@ -4706,20 +4924,23 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart endif ! Still painfully inefficient, now in four dimensions. + ! Allocating both for now so that the pass_vector works. if (any(OBC%tracer_x_reservoirs_used)) then allocate(OBC%tres_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke,OBC%ntr)) OBC%tres_x(:,:,:,:) = 0.0 do m=1,OBC%ntr if (OBC%tracer_x_reservoirs_used(m)) then - if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) - else +! if (modulo(HI%turns, 2) /= 0) then +! write(mesg,'("tres_y_",I3.3)') m +! longname="Tracer concentration for NS OBCs for "//trim(Reg%Tr(m)%name) +! vd(1) = var_desc(mesg,"Conc", longname,'v','L') +! call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) +! else write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') + longname="Tracer concentration for EW OBCs for "//trim(Reg%Tr(m)%name) + vd(1) = var_desc(mesg,"Conc", longname,'u','L') call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) - endif +! endif endif enddo endif @@ -4728,15 +4949,17 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart OBC%tres_y(:,:,:,:) = 0.0 do m=1,OBC%ntr if (OBC%tracer_y_reservoirs_used(m)) then - if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) - else +! if (modulo(HI%turns, 2) /= 0) then +! write(mesg,'("tres_x_",I3.3)') m +! longname="Tracer concentration for EW OBCs for "//trim(Reg%Tr(m)%name) +! vd(1) = var_desc(mesg,"Conc", longname,'u','L') +! call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) +! else write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') + longname="Tracer concentration for NS OBCs for "//trim(Reg%Tr(m)%name) + vd(1) = var_desc(mesg,"Conc", longname,'v','L') call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) - endif +! endif endif enddo endif @@ -4787,7 +5010,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) fac1 = 1.0 + (u_L_out-u_L_in) - segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & + segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & !NOT reproduce across restart + !segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(OBC%tres_x(I,j,k,m) + & !NOT reproduce + !segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%t(I,j,k) + & !Reproduce (u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) @@ -4812,7 +5037,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) fac1 = 1.0 + (v_L_out-v_L_in) - segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & + segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & !NOT reproduce across restart + !segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(OBC%tres_y(i,J,k,m) + & !NOT reproduce + !segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%t(i,J,k) + & !Reproduce (v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) if (associated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%tres(i,J,k) @@ -4872,8 +5099,8 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The normal slope at the boundary is zero by a ! previous call to open_boundary_impose_normal_slope do k=nz+1,1,-1 - if (-eta(i,j,k) > segment%Htot(i,j) + hTolerance) then - eta(i,j,k) = -segment%Htot(i,j) + if (-eta(i,j,k) > segment%Htot(i,j)*GV%H_to_Z + hTolerance) then + eta(i,j,k) = -segment%Htot(i,j)*GV%H_to_Z contractions = contractions + 1 endif enddo @@ -4891,10 +5118,10 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. - if (-eta(i,j,nz+1) < segment%Htot(i,j) - hTolerance) then + if (-eta(i,j,nz+1) < (segment%Htot(i,j) * GV%H_to_Z) - hTolerance) then dilations = dilations + 1 ! expand bottom-most cell only - eta(i,j,nz+1) = -segment%Htot(i,j) + eta(i,j,nz+1) = -(segment%Htot(i,j) * GV%H_to_Z) segment%field(fld)%dz_src(i,j,nz)= eta(i,j,nz)-eta(i,j,nz+1) ! if (eta(i,j,1) <= eta(i,j,nz+1)) then ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo @@ -4940,6 +5167,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) integer :: l + if (OBC_in%number_of_segments==0) return + ! Scalar and logical transfer OBC%number_of_segments = OBC_in%number_of_segments OBC%ke = OBC_in%ke @@ -4960,7 +5189,7 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) ! Segment rotation allocate(OBC%segment(0:OBC%number_of_segments)) - do l = 0, OBC%number_of_segments + do l = 1, OBC%number_of_segments call rotate_OBC_segment_config(OBC_in%segment(l), G_in, OBC%segment(l), G, turns) ! Data up to setup_[uv]_point_obc is needed for allocate_obc_segment_data! call allocate_OBC_segment_data(OBC, OBC%segment(l)) @@ -4997,8 +5226,10 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%OBC_pe = OBC_in%OBC_pe ! remap_CS is set up by initialize_segment_data, so we copy the fields here. - allocate(OBC%remap_CS) - OBC%remap_CS = OBC_in%remap_CS + if (ASSOCIATED(OBC_in%remap_CS)) then + allocate(OBC%remap_CS) + OBC%remap_CS = OBC_in%remap_CS + endif ! TODO: The OBC registry seems to be a list of "registered" OBC types. ! It does not appear to be used, so for now we skip this record. @@ -5157,7 +5388,7 @@ subroutine rotate_OBC_init(OBC_in, G, GV, US, param_file, tv, restart_CSp, OBC) "If true, Temperature and salinity are used as state "//& "variables.", default=.true., do_not_log=.true.) - do l = 0, OBC%number_of_segments + do l = 1, OBC%number_of_segments call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), G%HI%turns) enddo diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 97e5b36db5..0b225f0bf7 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -80,7 +80,7 @@ module MOM_variables type, public :: thermo_var_ptrs ! 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]. + real, pointer :: S(:,:,:) => NULL() !< Salinity [PSU] or [gSalt/kg], generically [ppt]. real, pointer :: p_surf(:,:) => NULL() !< Ocean surface pressure used in equation of state !! calculations [R L2 T-2 ~> Pa] type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the @@ -116,6 +116,12 @@ module MOM_variables !< Any internal or geothermal heat sources that !! have been applied to the ocean since the last call to !! calculate_surface_state [degC R Z ~> degC kg m-2]. + ! The following variables are most normally not used but when they are they + ! will be either set by parameterizations or prognostic. + real, pointer :: varT(:,:,:) => NULL() !< SGS variance of potential temperature [degC2]. + real, pointer :: varS(:,:,:) => NULL() !< SGS variance of salinity [ppt2]. + real, pointer :: covarTS(:,:,:) => NULL() !< SGS covariance of salinity and potential + !! temperature [degC ppt]. end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. @@ -179,6 +185,8 @@ module MOM_variables real, pointer :: rv_x_v(:,:,:) => NULL() !< rv_x_v = rv * v at u [L T-2 ~> m s-2] real, pointer :: rv_x_u(:,:,:) => NULL() !< rv_x_u = rv * u at v [L T-2 ~> m s-2] + real, pointer :: diag_hfrac_u(:,:,:) => NULL() !< Fractional layer thickness at u points + real, pointer :: diag_hfrac_v(:,:,:) => NULL() !< Fractional layer thickness at v points end type accel_diag_ptrs !> Pointers to arrays with transports, which can later be used for derived diagnostics, like energy balances. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index e08c920c60..3936a788d0 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -6,6 +6,7 @@ module MOM_diagnostics ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : reproducing_sum +use MOM_density_integrals, only : int_density_dz use MOM_diag_mediator, only : post_data, get_diag_time_end use MOM_diag_mediator, only : register_diag_field, register_scalar_field use MOM_diag_mediator, only : register_static_field, diag_register_area_ids @@ -15,7 +16,7 @@ module MOM_diagnostics use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids, diag_copy_storage_to_diag use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_North, To_East -use MOM_EOS, only : calculate_density, int_density_dz, EOS_domain +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type @@ -70,6 +71,9 @@ module MOM_diagnostics dv_dt => NULL(), & !< net j-acceleration [L T-2 ~> m s-2] dh_dt => NULL(), & !< thickness rate of change [H T-1 ~> m s-1 or kg m-2 s-1] p_ebt => NULL() !< Equivalent barotropic modal structure [nondim] + ! hf_du_dt => NULL(), hf_dv_dt => NULL() !< du_dt, dv_dt x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_du(dv)_dt are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. real, pointer, dimension(:,:,:) :: h_Rlay => NULL() !< Layer thicknesses in potential density !! coordinates [H ~> m or kg m-2] @@ -109,6 +113,8 @@ module MOM_diagnostics integer :: id_u = -1, id_v = -1, id_h = -1 integer :: id_e = -1, id_e_D = -1 integer :: id_du_dt = -1, id_dv_dt = -1 + ! integer :: id_hf_du_dt = -1, id_hf_dv_dt = -1 + integer :: id_hf_du_dt_2d = -1, id_hf_dv_dt_2d = -1 integer :: id_col_ht = -1, id_dh_dt = -1 integer :: id_KE = -1, id_dKEdt = -1 integer :: id_PE_to_KE = -1, id_KE_Coradv = -1 @@ -134,6 +140,7 @@ module MOM_diagnostics integer :: id_pbo = -1 integer :: id_thkcello = -1, id_rhoinsitu = -1 integer :: id_rhopot0 = -1, id_rhopot2 = -1 + integer :: id_drho_dT = -1, id_drho_dS = -1 integer :: id_h_pre_sync = -1 !>@} !> The control structure for calculating wave speed. @@ -231,6 +238,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. real :: rho_in_situ(SZI_(G)) ! In situ density [R ~> kg m-3] + real, allocatable, dimension(:,:) :: & + hf_du_dt_2d, hf_dv_dt_2d ! z integeral of hf_du_dt, hf_dv_dt [L T-2 ~> m s-2]. + ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] @@ -270,6 +280,44 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_dh_dt>0) call post_data(CS%id_dh_dt, CS%dh_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_du(dv)_dt are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_du_dt > 0) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_du_dt(I,j,k) = CS%du_dt(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_du_dt, CS%hf_du_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !endif + + !if (CS%id_hf_dv_dt > 0) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_dv_dt(i,J,k) = CS%dv_dt(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_dv_dt, CS%hf_dv_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !endif + + if (CS%id_hf_du_dt_2d > 0) then + allocate(hf_du_dt_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_du_dt_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_du_dt_2d(I,j) = hf_du_dt_2d(I,j) + CS%du_dt(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_du_dt_2d, hf_du_dt_2d, CS%diag) + deallocate(hf_du_dt_2d) + endif + + if (CS%id_hf_dv_dt_2d > 0) then + allocate(hf_dv_dt_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dv_dt_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dv_dt_2d(i,J) = hf_dv_dt_2d(i,J) + CS%dv_dt(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dv_dt_2d, hf_dv_dt_2d, CS%diag) + deallocate(hf_dv_dt_2d) + endif + call diag_restore_grids(CS%diag) call calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS) @@ -619,6 +667,22 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo if (CS%id_rhoinsitu > 0) call post_data(CS%id_rhoinsitu, Rcv, CS%diag) endif + + if (CS%id_drho_dT > 0 .or. CS%id_drho_dS > 0) then + !$OMP parallel do default(shared) private(pressure_1d) + do j=js,je + pressure_1d(:) = 0. ! Start at p=0 Pa at surface + do k=1,nz + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * GV%H_to_Pa ! Pressure in middle of layer k + ! To avoid storing more arrays, put drho_dT into Rcv, and drho_dS into work3d + call calculate_density_derivs(tv%T(:,j,k),tv%S(:,j,k),pressure_1d, & + Rcv(:,j,k),work_3d(:,j,k),is,ie-is+1, tv%eqn_of_state) + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * GV%H_to_Pa ! Pressure at bottom of layer k + enddo + enddo + if (CS%id_drho_dT > 0) call post_data(CS%id_drho_dT, Rcv, CS%diag) + if (CS%id_drho_dS > 0) call post_data(CS%id_drho_dS, work_3d, CS%diag) + endif endif if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & @@ -846,7 +910,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) enddo ; enddo call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & - G%HI, tv%eqn_of_state, dpress) + G%HI, tv%eqn_of_state, US, dpress) do j=js,je ; do i=is,ie mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth enddo ; enddo @@ -1600,6 +1664,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'Potential density referenced to 2000 dbar', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_rhoinsitu = register_diag_field('ocean_model', 'rhoinsitu', diag%axesTL, Time, & 'In situ density', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_drho_dT = register_diag_field('ocean_model', 'drho_dT', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to temperature (alpha)', 'kg m-3 degC-1') + CS%id_drho_dS = register_diag_field('ocean_model', 'drho_dS', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to salinity (beta)', 'kg^2 g-1 m-3') CS%id_du_dt = register_diag_field('ocean_model', 'dudt', diag%axesCuL, Time, & 'Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) @@ -1622,6 +1690,50 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call register_time_deriv(lbound(MIS%h), MIS%h, CS%dh_dt, CS) endif + !CS%id_hf_du_dt = register_diag_field('ocean_model', 'hf_dudt', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration', 'm s-2', v_extensive=.true., & + ! conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_du_dt > 0) then + ! call safe_alloc_ptr(CS%hf_du_dt,IsdB,IedB,jsd,jed,nz) + ! if (.not.associated(CS%du_dt)) then + ! call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + ! call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + ! endif + ! call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_dv_dt = register_diag_field('ocean_model', 'hf_dvdt', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration', 'm s-2', v_extensive=.true., & + ! conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_dv_dt > 0) then + ! call safe_alloc_ptr(CS%hf_dv_dt,isd,ied,JsdB,JedB,nz) + ! if (.not.associated(CS%dv_dt)) then + ! call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) + ! call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + ! endif + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_du_dt_2d = register_diag_field('ocean_model', 'hf_dudt_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_du_dt_2d > 0) then + if (.not.associated(CS%du_dt)) then + call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_dv_dt_2d = register_diag_field('ocean_model', 'hf_dvdt_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dv_dt_2d > 0) then + if (.not.associated(CS%dv_dt)) then + call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) + call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + ! layer thickness variables !if (GV%nk_rho_varies > 0) then CS%id_h_Rlay = register_diag_field('ocean_model', 'h_rho', diag%axesTL, Time, & @@ -2156,6 +2268,9 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(ADp%du_other)) deallocate(ADp%du_other) if (associated(ADp%dv_other)) deallocate(ADp%dv_other) + if (associated(ADp%diag_hfrac_u)) deallocate(ADp%diag_hfrac_u) + if (associated(ADp%diag_hfrac_v)) deallocate(ADp%diag_hfrac_v) + do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo deallocate(CS) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 9da2963c16..b3321cdace 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -806,7 +806,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & - !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes) + !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & + !$OMP c1_thresh,tol_solve,tol_merge) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c584b68c89..40ac04e9e8 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -37,20 +37,27 @@ module MOM_EOS #include -public calculate_compress, calculate_density, query_compressible -public calculate_density_derivs, calculate_specific_vol_derivs +public EOS_allocate +public EOS_domain +public EOS_end +public EOS_init +public EOS_manual_init +public EOS_quadrature +public EOS_use_linear +public analytic_int_density_dz +public analytic_int_specific_vol_dp +public calculate_compress +public calculate_density +public calculate_density_derivs public calculate_density_second_derivs -public EOS_init, EOS_manual_init, EOS_end, EOS_allocate, EOS_domain -public EOS_use_linear, calculate_spec_vol -public int_density_dz, int_specific_vol_dp -public int_density_dz_generic_plm, int_density_dz_generic_ppm -public int_spec_vol_dp_generic_plm !, int_spec_vol_dz_generic_ppm -public int_density_dz_generic, int_spec_vol_dp_generic -public find_depth_of_pressure_in_cell +public calculate_spec_vol +public calculate_specific_vol_derivs public calculate_TFreeze public convert_temp_salt_for_TEOS10 -public gsw_sp_from_sr, gsw_pt_from_ct public extract_member_EOS +public gsw_sp_from_sr +public gsw_pt_from_ct +public query_compressible ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -60,6 +67,8 @@ module MOM_EOS !> Calculates density of sea water from T, S and P interface calculate_density module procedure calculate_density_scalar, calculate_density_array, calculate_density_1d + module procedure calculate_stanley_density_scalar, calculate_stanley_density_array + module procedure calculate_stanley_density_1d end interface calculate_density !> Calculates specific volume of sea water from T, S and P @@ -174,7 +183,7 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_density_linear(T, S, p_scale*pressure, rho, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) case (EOS_UNESCO) call calculate_density_unesco(T, S, p_scale*pressure, rho, rho_ref) case (EOS_WRIGHT) @@ -193,6 +202,61 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) end subroutine calculate_density_scalar +!> Calls the appropriate subroutine to calculate density of sea water for scalar inputs +!! including the variance of T, S and covariance of T-S. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The +!! density can be rescaled using rho_ref. +subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, rho, EOS, rho_ref, scale) + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, intent(in) :: Svar !< Variance of salinity [ppt2] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + ! Local variables + real :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_stanley_density_scalar called with an unassociated EOS_type EOS.") + + p_scale = EOS%RL2_T2_to_Pa + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, p_scale*pressure, rho, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, p_scale*pressure, rho, rho_ref) + call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, p_scale*pressure, rho, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case default + call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") + end select + + ! Equation 25 of Stanley et al., 2020. + rho = rho + ( 0.5 * d2RdTT * Tvar + ( d2RdST * TScov + 0.5 * d2RdSS * Svar ) ) + + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + rho = rho_scale * rho + +end subroutine calculate_stanley_density_scalar + !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, scale) @@ -206,27 +270,26 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] - integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pressure, rho, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) - case default - call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") - end select + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pressure, rho, start, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) + case default + call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") + end select if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 rho(j) = scale * rho(j) @@ -234,6 +297,62 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re end subroutine calculate_density_array +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs +!! including the variance of T, S and covariance of T-S. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rho, start, npts, EOS, rho_ref, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] + integer, intent(in) :: start !< Start index for computation + integer, intent(in) :: npts !< Number of point to compute + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + ! Local variables + real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + integer :: j + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_array called with an unassociated EOS_type EOS.") + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pressure, rho, start, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case default + call MOM_error(FATAL, "calculate_stanley_density_array: EOS%form_of_EOS is not valid.") + end select + + ! Equation 25 of Stanley et al., 2020. + do j=start,start+npts-1 + rho(j) = rho(j) & + + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) + enddo + + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + rho(j) = scale * rho(j) + enddo ; endif ; endif + +end subroutine calculate_stanley_density_array + !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs, !! potentially limiting the domain of indices that are worked on. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. @@ -288,6 +407,79 @@ subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale) end subroutine calculate_density_1d +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs +!! including the variance of T, S and covariance of T-S, +!! potentially limiting the domain of indices that are worked on. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, EOS, dom, rho_ref, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature [degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + integer :: i, is, ie, npts + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_1d called with an unassociated EOS_type EOS.") + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(rho) ; npts = 1 + ie - is + endif + + p_scale = EOS%RL2_T2_to_Pa + do i=is,ie + pres(i) = p_scale * pressure(i) + enddo + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pres, rho, 1, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pres, rho, 1, npts, rho_ref) + call calculate_density_second_derivs_wright(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pres, rho, 1, npts, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) + case default + call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") + end select + + ! Equation 25 of Stanley et al., 2020. + do i=is,ie + rho(i) = rho(i) & + + ( 0.5 * d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + 0.5 * d2RdSS(i) * Svar(i) ) ) + enddo + + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do i=is,ie + rho(i) = rho_scale * rho(i) + enddo ; endif + +end subroutine calculate_stanley_density_1d + !> Calls the appropriate subroutine to calculate the specific volume of sea water !! for 1-D array inputs. subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref, scale) @@ -990,7 +1182,7 @@ end function EOS_domain !! non-Boussinesq model. There are essentially no free assumptions, apart from the !! use of Bode's rule to do the horizontal integrals, and from a truncation in the !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. -subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & +subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & bathyP, dP_tiny, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure @@ -1037,11 +1229,11 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & if (.not.associated(EOS)) call MOM_error(FATAL, & "int_specific_vol_dp called with an unassociated EOS_type EOS.") - if (EOS%EOS_quadrature) then - call int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) - else ; select case (EOS%form_of_EOS) + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + select case (EOS%form_of_EOS) case (EOS_LINEAR) call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & EOS%kg_m3_to_R*EOS%dRho_dT, EOS%kg_m3_to_R*EOS%dRho_dS, dza, & @@ -1052,17 +1244,15 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa) case default - call int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) - end select ; endif + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select -end subroutine int_specific_vol_dp +end subroutine analytic_int_specific_vol_dp !> This subroutine calculates analytical and nearly-analytical integrals of !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. -subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & +subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -1110,10 +1300,11 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & if (.not.associated(EOS)) call MOM_error(FATAL, & "int_density_dz called with an unassociated EOS_type EOS.") - if (EOS%EOS_quadrature) then - call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) - else ; select case (EOS%form_of_EOS) + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + select case (EOS%form_of_EOS) case (EOS_LINEAR) rho_scale = EOS%kg_m3_to_R if (rho_scale /= 1.0) then @@ -1138,11 +1329,10 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & dz_neglect, useMassWghtInterp) endif case default - call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) - end select ; endif + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select -end subroutine int_density_dz +end subroutine analytic_int_density_dz !> Returns true if the equation of state is compressible (i.e. has pressure dependence) logical function query_compressible(EOS) @@ -1336,1570 +1526,6 @@ subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) end subroutine EOS_use_linear -!> This subroutine calculates (by numerical quadrature) integrals of -!! pressure anomalies across layers, which are required for calculating the -!! finite-volume form pressure accelerations in a Boussinesq model. -subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI !< Horizontal index type for variables. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T !< Potential temperature of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity of the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is - !! subtracted out to reduce the magnitude - !! of each of the integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used - !! to calculate the pressure (as p~=-z*rho_0*G_e) - !! used in the equation of state. - real, intent(in) :: G_e !< The Earth's gravitational acceleration - !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly - !! across the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intz_dpa !< The integral through the thickness of the - !! layer of the pressure anomaly relative to the - !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: intx_dpa !< The integral in x of the difference between - !! the pressure anomaly at the top and bottom of the - !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: inty_dpa !< The integral in y of the difference between - !! the pressure anomaly at the top and bottom of the - !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] - real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - ! Local variables - real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] - real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] - real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] - real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3] - real :: w_left, w_right ! Left and right weights [nondim] - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - real :: dz ! The layer thickness [Z ~> m] - real :: hWght ! A pressure-thickness below topography [Z ~> m] - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] - real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] - real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] - real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] - logical :: do_massWeight ! Indicates whether to do mass weighting. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n - - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - Isq = HI%IscB ; Ieq = HI%IecB - Jsq = HI%JscB ; Jeq = HI%JecB - is = HI%isc ; ie = HI%iec - js = HI%jsc ; je = HI%jec - - rho_scale = EOS%kg_m3_to_R - GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref * EOS%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "bathyT must be present if useMassWghtInterp is present and true.") - if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - dpa(i,j) = G_e*dz*rho_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the pressure anomaly. - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - enddo ; enddo - - if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) - p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) - enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo ; enddo ; endif - - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) - enddo - ! Use Bode's rule to integrate the values. - inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo ; enddo ; endif -end subroutine int_density_dz_generic - - -! ========================================================================== -!> Compute pressure gradient force integrals by quadrature for the case where -!! T and S are linear profiles. -subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & - rho_0, G_e, dz_subroundoff, bathyT, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted - !! out to reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate - !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. - real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real, intent(in) :: dz_subroundoff !< A miniscule thickness change [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of - !! the pressure anomaly relative to the anomaly at the - !! top of the layer [R L2 Z T-2 ~> Pa Z] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the - !! pressure anomaly at the top and bottom of the layer - !! divided by the x grid spacing [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the - !! pressure anomaly at the top and bottom of the layer - !! divided by the y grid spacing [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - -! This subroutine calculates (by numerical quadrature) integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. The one -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! It is assumed that the salinity and temperature profiles are linear in the -! vertical. The top and bottom values within each layer are provided and -! a linear interpolation is used to compute intermediate values. - - ! Local variables - real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [degC] - real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [ppt] - real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations, never - ! rescaled from Pa [Pa] - real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid - ! locations [R ~> kg m-3] or [kg m-3] - real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [degC] - real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [ppt] - real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [Pa] - real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations - ! [R ~> kg m-3] or [kg m-3] - real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] - real :: rho_anom ! A density anomaly [R ~> kg m-3] or [kg m-3] - real :: w_left, w_right ! Left and right weights [nondim] - real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] - real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m] - real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m] - real :: weight_t, weight_b ! Nondimensional weights of the top and bottom [nondim] - real :: massWeightToggle ! A nondimensional toggle factor (0 or 1) [nondim] - real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC] - real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [ppt] - real :: hWght ! A topographically limited thicknes weight [Z ~> m] - real :: hL, hR ! Thicknesses to the left and right [Z ~> m] - real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] - integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n - integer :: pos - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - - rho_scale = EOS%kg_m3_to_R - GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref * EOS%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. - endif - - do n = 1, 5 - wt_t(n) = 0.25 * real(5-n) - wt_b(n) = 1.0 - wt_t(n) - enddo - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1 - do i = Isq,Ieq+1 - dz(i) = z_t(i,j) - z_b(i,j) - do n=1,5 - p5(i*5+n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz(i)) - ! Salinity and temperature points are linearly interpolated - S5(i*5+n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) - T5(i*5+n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) - enddo - enddo - if (rho_scale /= 1.0) then - call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) - endif - - do i=isq,ieq+1 - ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) - dpa(i,j) = G_e*dz(i)*rho_anom - if (present(intz_dpa)) then - ! Use a Bode's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & - (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) - endif - enddo - enddo ! end loops on j - - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec - do I=Isq,Ieq - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i+1,j) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i+1,j) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i+1,j) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i+1,j) ) * iDenom - Stl = ( (hWght*hR)*S_t(i+1,j) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i+1,j) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i+1,j) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i+1,j) ) * iDenom - else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i+1,j); Tbr = T_b(i+1,j) - Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i+1,j); Sbr = S_b(i+1,j) - endif - - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_x(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr - - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr - - p15(pos+1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) - - ! Pressure - do n=2,5 - p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) - enddo - - ! Salinity and temperature (linear interpolation in the vertical) - do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) - enddo - enddo - enddo - - if (rho_scale /= 1.0) then - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) - endif - - do I=Isq,Ieq - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) - enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo - enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dpa)) then ; do J=Jsq,Jeq - do i=HI%isc,HI%iec - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i,j+1) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i,j+1) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i,j+1) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i,j+1) ) * iDenom - Stl = ( (hWght*hR)*S_t(i,j+1) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i,j+1) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i,j+1) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i,j+1) ) * iDenom - else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i,j+1); Tbr = T_b(i,j+1) - Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i,j+1); Sbr = S_b(i,j+1) - endif - - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_y(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr - - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr - - p15(pos+1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) - - ! Pressure - do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) ; enddo - - ! Salinity and temperature (linear interpolation in the vertical) - do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) - enddo - enddo - enddo - - if (rho_scale /= 1.0) then - call calculate_density_array(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & - rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density_array(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) - endif - do i=HI%isc,HI%iec - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & - 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) - enddo - ! Use Bode's rule to integrate the values. - inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo - enddo ; endif - -end subroutine int_density_dz_generic_plm -! ========================================================================== -! Above is the routine where only the S and T profiles are modified -! The real topography is still used -! ========================================================================== - -!> Find the depth at which the reconstructed pressure matches P_tgt -subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & - rho_ref, G_e, EOS, P_b, z_out, z_tol) - real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, intent(in) :: S_t !< Salinity at the cell top [ppt] - real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m] (Boussinesq ????) - real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m] - real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative to g*rho_ref*z_t [R L2 T-2 ~> Pa] - real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [R L2 T-2 ~> Pa] - real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to [R ~> kg m-3] - real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> Pa] - real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m] - real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] - - ! Local variables - real :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] - real :: F_guess, F_l, F_r ! Fractional positions [nondim] - real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] - real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] - character(len=240) :: msg - - GxRho = G_e * rho_ref - - ! Anomalous pressure difference across whole cell - dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) - - P_b = P_t + dp ! Anomalous pressure at bottom of cell - - if (P_tgt <= P_t ) then - z_out = z_t - return - endif - - if (P_tgt >= P_b) then - z_out = z_b - return - endif - - F_l = 0. - Pa_left = P_t - P_tgt ! Pa_left < 0 - F_r = 1. - Pa_right = P_b - P_tgt ! Pa_right > 0 - Pa_tol = GxRho * 1.0e-5*EOS%m_to_Z - if (present(z_tol)) Pa_tol = GxRho * z_tol - - F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) - Pa = Pa_right - Pa_left ! To get into iterative loop - do while ( abs(Pa) > Pa_tol ) - - z_out = z_t + ( z_b - z_t ) * F_guess - Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) - - if (PaPa_right) then - write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt - call MOM_error(FATAL, 'find_depth_of_pressure_in_cell out of bounds positive: /n'//msg) - elseif (Pa>0.) then - Pa_right = Pa - F_r = F_guess - else ! Pa == 0 - return - endif - F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) - - enddo - -end subroutine find_depth_of_pressure_in_cell - -!> Returns change in anomalous pressure change from top to non-dimensional -!! position pos between z_t and z_b -real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) - real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, intent(in) :: S_t !< Salinity at the cell top [ppt] - real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] - real, intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted out to - !! reduce the magnitude of each of the integrals. - real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] - type(EOS_type), pointer :: EOS !< Equation of state structure - real :: fract_dp_at_pos !< The change in pressure from the layer top to - !! fractional position pos [R L2 T-2 ~> Pa] - ! Local variables - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] - real :: dz ! Distance from the layer top [Z ~> m] - real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] - real :: rho_ave ! Average density [R ~> kg m-3] - real, dimension(5) :: T5 ! Tempratures at quadrature points [degC] - real, dimension(5) :: S5 ! Salinities at quadrature points [ppt] - real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] - real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] - integer :: n - - do n=1,5 - ! Evalute density at five quadrature points - bottom_weight = 0.25*real(n-1) * pos - top_weight = 1.0 - bottom_weight - ! Salinity and temperature points are linearly interpolated - S5(n) = top_weight * S_t + bottom_weight * S_b - T5(n) = top_weight * T_t + bottom_weight * T_b - p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) - enddo - call calculate_density_1d(T5, S5, p5, rho5, EOS) - rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref - - ! Use Bode's rule to estimate the average density - rho_ave = C1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3)) - - dz = ( z_t - z_b ) * pos - frac_dp_at_pos = G_e * dz * rho_ave -end function frac_dp_at_pos - - -! ========================================================================== -!> Compute pressure gradient force integrals for the case where T and S -!! are parabolic profiles -subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & - z_t, z_b, rho_ref, rho_0, G_e, HI, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa) - - type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_t !< Height at the top of the layer [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is - !! subtracted out to reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate - !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. - real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of - !! the pressure anomaly relative to the anomaly at the - !! top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the - !! pressure anomaly at the top and bottom of the layer - !! divided by the x grid spacing [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the - !! pressure anomaly at the top and bottom of the layer - !! divided by the y grid spacing [R L2 T-2 ~> Pa] - -! This subroutine calculates (by numerical quadrature) integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. The one -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! It is assumed that the salinity and temperature profiles are linear in the -! vertical. The top and bottom values within each layer are provided and -! a linear interpolation is used to compute intermediate values. - -!### Please note that this subroutine has not been verified to work properly! - - ! Local variables - real :: T5(5), S5(5) - real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] - real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] - real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [kg m-3] - real :: w_left, w_right ! Left and right weights [nondim] - real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - real :: dz - real :: weight_t, weight_b - real :: s0, s1, s2 ! parabola coefficients for S [ppt] - real :: t0, t1, t2 ! parabola coefficients for T [degC] - real :: xi ! normalized coordinate - real :: T_top, T_mid, T_bot - real :: S_top, S_mid, S_bot - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n - real, dimension(4) :: x, y - real, dimension(9) :: S_node, T_node, p_node, r_node - - - call MOM_error(FATAL, & - "int_density_dz_generic_ppm: the implementation is not done yet, contact developer") - - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - Isq = HI%IscB ; Ieq = HI%IecB - Jsq = HI%JscB ; Jeq = HI%JecB - is = HI%isc ; ie = HI%iec - js = HI%jsc ; je = HI%jec - - rho_scale = EOS%kg_m3_to_R - GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref * EOS%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - - ! Coefficients of the parabola for S - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0*S(i,j) ) - - ! Coefficients of the parabola for T - t0 = T_t(i,j) - t1 = 6.0 * T(i,j) - 4.0 * T_t(i,j) - 2.0 * T_b(i,j) - t2 = 3.0 * ( T_t(i,j) + T_b(i,j) - 2.0*T(i,j) ) - - do n=1,5 - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 - enddo - - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - - dpa(i,j) = G_e*dz*rho_anom - - ! Use a Bode's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - - enddo ; enddo ! end loops on j and i - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - T_top = w_left*T_t(i,j) + w_right*T_t(i+1,j) - T_mid = w_left*T(i,j) + w_right*T(i+1,j) - T_bot = w_left*T_b(i,j) + w_right*T_b(i+1,j) - - S_top = w_left*S_t(i,j) + w_right*S_t(i+1,j) - S_mid = w_left*S(i,j) + w_right*S(i+1,j) - S_bot = w_left*S_b(i,j) + w_right*S_b(i+1,j) - - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) - - ! Pressure - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - - ! Coefficients of the parabola for S - s0 = S_top - s1 = 6.0 * S_mid - 4.0 * S_top - 2.0 * S_bot - s2 = 3.0 * ( S_top + S_bot - 2.0*S_mid ) - - ! Coefficients of the parabola for T - t0 = T_top - t1 = 6.0 * T_mid - 4.0 * T_top - 2.0 * T_bot - t2 = 3.0 * ( T_top + T_bot - 2.0*T_mid ) - - do n=1,5 - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 - enddo - - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & - 12.0*r5(3)) ) - enddo - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - - ! Use Gauss quadrature rule to compute integral - - ! The following coordinates define the quadrilateral on which the integral - ! is computed - x(1) = 1.0 - x(2) = 0.0 - x(3) = 0.0 - x(4) = 1.0 - y(1) = z_t(i+1,j) - y(2) = z_t(i,j) - y(3) = z_b(i,j) - y(4) = z_b(i+1,j) - - T_node = 0.0 - p_node = 0.0 - - ! Nodal values for S - - ! Parabolic reconstruction on the left - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0 * S(i,j) ) - S_node(2) = s0 - S_node(6) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(3) = s0 + s1 + s2 - - ! Parabolic reconstruction on the left - s0 = S_t(i+1,j) - s1 = 6.0 * S(i+1,j) - 4.0 * S_t(i+1,j) - 2.0 * S_b(i+1,j) - s2 = 3.0 * ( S_t(i+1,j) + S_b(i+1,j) - 2.0 * S(i+1,j) ) - S_node(1) = s0 - S_node(8) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(4) = s0 + s1 + s2 - - S_node(5) = 0.5 * ( S_node(2) + S_node(1) ) - S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) - S_node(7) = 0.5 * ( S_node(3) + S_node(4) ) - - if (rho_scale /= 1.0) then - call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks, scale=rho_scale ) - else - call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks) - endif - r_node = r_node - rho_ref - - call compute_integral_quadratic( x, y, r_node, intx_dpa(i,j) ) - - intx_dpa(i,j) = intx_dpa(i,j) * G_e - - enddo ; enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dpa)) then - call MOM_error(WARNING, "int_density_dz_generic_ppm still needs to be written for inty_dpa!") - do J=Jsq,Jeq ; do i=is,ie - - inty_dpa(i,j) = 0.0 - - enddo ; enddo - endif - -end subroutine int_density_dz_generic_ppm - - - -! ============================================================================= -!> Compute the integral of the quadratic function -subroutine compute_integral_quadratic( x, y, f, integral ) - real, dimension(4), intent(in) :: x !< The x-position of the corners - real, dimension(4), intent(in) :: y !< The y-position of the corners - real, dimension(9), intent(in) :: f !< The function at the quadrature points - real, intent(out) :: integral !< The returned integral - - ! Local variables - integer :: i, k - real, dimension(9) :: weight, xi, eta ! integration points - real :: f_k - real :: dxdxi, dxdeta - real :: dydxi, dydeta - real, dimension(4) :: phiiso, dphiisodxi, dphiisodeta - real, dimension(9) :: phi, dphidxi, dphideta - real :: jacobian_k - real :: t - - ! Quadrature rule (4 points) - !weight(:) = 1.0 - !xi(1) = - sqrt(3.0) / 3.0 - !xi(2) = sqrt(3.0) / 3.0 - !xi(3) = sqrt(3.0) / 3.0 - !xi(4) = - sqrt(3.0) / 3.0 - !eta(1) = - sqrt(3.0) / 3.0 - !eta(2) = - sqrt(3.0) / 3.0 - !eta(3) = sqrt(3.0) / 3.0 - !eta(4) = sqrt(3.0) / 3.0 - - ! Quadrature rule (9 points) - t = sqrt(3.0/5.0) - weight(1) = 25.0/81.0 ; xi(1) = -t ; eta(1) = t - weight(2) = 40.0/81.0 ; xi(2) = .0 ; eta(2) = t - weight(3) = 25.0/81.0 ; xi(3) = t ; eta(3) = t - weight(4) = 40.0/81.0 ; xi(4) = -t ; eta(4) = .0 - weight(5) = 64.0/81.0 ; xi(5) = .0 ; eta(5) = .0 - weight(6) = 40.0/81.0 ; xi(6) = t ; eta(6) = .0 - weight(7) = 25.0/81.0 ; xi(7) = -t ; eta(7) = -t - weight(8) = 40.0/81.0 ; xi(8) = .0 ; eta(8) = -t - weight(9) = 25.0/81.0 ; xi(9) = t ; eta(9) = -t - - integral = 0.0 - - ! Integration loop - do k = 1,9 - - ! Evaluate shape functions and gradients for isomorphism - call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & - dphiisodxi, dphiisodeta ) - - ! Determine gradient of global coordinate at integration point - dxdxi = 0.0 - dxdeta = 0.0 - dydxi = 0.0 - dydeta = 0.0 - - do i = 1,4 - dxdxi = dxdxi + x(i) * dphiisodxi(i) - dxdeta = dxdeta + x(i) * dphiisodeta(i) - dydxi = dydxi + y(i) * dphiisodxi(i) - dydeta = dydeta + y(i) * dphiisodeta(i) - enddo - - ! Evaluate Jacobian at integration point - jacobian_k = dxdxi*dydeta - dydxi*dxdeta - - ! Evaluate shape functions for interpolation - call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) - - ! Evaluate function at integration point - f_k = 0.0 - do i = 1,9 - f_k = f_k + f(i) * phi(i) - enddo - - integral = integral + weight(k) * f_k * jacobian_k - - enddo ! end integration loop - -end subroutine compute_integral_quadratic - - -! ============================================================================= -!> Evaluation of the four bilinear shape fn and their gradients at (xi,eta) -subroutine evaluate_shape_bilinear( xi, eta, phi, dphidxi, dphideta ) - real, intent(in) :: xi !< The x position to evaluate - real, intent(in) :: eta !< The z position to evaluate - real, dimension(4), intent(inout) :: phi !< The weights of the four corners at this point - real, dimension(4), intent(inout) :: dphidxi !< The x-gradient of the weights of the four - !! corners at this point - real, dimension(4), intent(inout) :: dphideta !< The z-gradient of the weights of the four - !! corners at this point - - ! The shape functions within the parent element are defined as shown here: - ! - ! (-1,1) 2 o------------o 1 (1,1) - ! | | - ! | | - ! | | - ! | | - ! (-1,-1) 3 o------------o 4 (1,-1) - ! - - phi(1) = 0.25 * ( 1 + xi ) * ( 1 + eta ) - phi(2) = 0.25 * ( 1 - xi ) * ( 1 + eta ) - phi(3) = 0.25 * ( 1 - xi ) * ( 1 - eta ) - phi(4) = 0.25 * ( 1 + xi ) * ( 1 - eta ) - - dphidxi(1) = 0.25 * ( 1 + eta ) - dphidxi(2) = - 0.25 * ( 1 + eta ) - dphidxi(3) = - 0.25 * ( 1 - eta ) - dphidxi(4) = 0.25 * ( 1 - eta ) - - dphideta(1) = 0.25 * ( 1 + xi ) - dphideta(2) = 0.25 * ( 1 - xi ) - dphideta(3) = - 0.25 * ( 1 - xi ) - dphideta(4) = - 0.25 * ( 1 + xi ) - -end subroutine evaluate_shape_bilinear - - -! ============================================================================= -!> Evaluation of the nine quadratic shape fn weights and their gradients at (xi,eta) -subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) - - ! Arguments - real, intent(in) :: xi !< The x position to evaluate - real, intent(in) :: eta !< The z position to evaluate - real, dimension(9), intent(inout) :: phi !< The weights of the 9 bilinear quadrature points - !! at this point - real, dimension(9), intent(inout) :: dphidxi !< The x-gradient of the weights of the 9 bilinear - !! quadrature points corners at this point - real, dimension(9), intent(inout) :: dphideta !< The z-gradient of the weights of the 9 bilinear - !! quadrature points corners at this point - - ! The quadratic shape functions within the parent element are defined as shown here: - ! - ! 5 (0,1) - ! (-1,1) 2 o------o------o 1 (1,1) - ! | | - ! | 9 (0,0) | - ! (-1,0) 6 o o o 8 (1,0) - ! | | - ! | | - ! (-1,-1) 3 o------o------o 4 (1,-1) - ! 7 (0,-1) - ! - - phi(:) = 0.0 - dphidxi(:) = 0.0 - dphideta(:) = 0.0 - - phi(1) = 0.25 * xi * ( 1 + xi ) * eta * ( 1 + eta ) - phi(2) = - 0.25 * xi * ( 1 - xi ) * eta * ( 1 + eta ) - phi(3) = 0.25 * xi * ( 1 - xi ) * eta * ( 1 - eta ) - phi(4) = - 0.25 * xi * ( 1 + xi ) * eta * ( 1 - eta ) - phi(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * eta * ( 1 + eta ) - phi(6) = - 0.5 * xi * ( 1 - xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * eta * ( 1 - eta ) - phi(8) = 0.5 * xi * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(9) = ( 1 - xi ) * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - - !dphidxi(1) = 0.25 * ( 1 + 2*xi ) * eta * ( 1 + eta ) - !dphidxi(2) = - 0.25 * ( 1 - 2*xi ) * eta * ( 1 + eta ) - !dphidxi(3) = 0.25 * ( 1 - 2*xi ) * eta * ( 1 - eta ) - !dphidxi(4) = - 0.25 * ( 1 + 2*xi ) * eta * ( 1 - eta ) - !dphidxi(5) = - xi * eta * ( 1 + eta ) - !dphidxi(6) = - 0.5 * ( 1 - 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(7) = xi * eta * ( 1 - eta ) - !dphidxi(8) = 0.5 * ( 1 + 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(9) = - 2 * xi * ( 1 - eta ) * ( 1 + eta ) - - !dphideta(1) = 0.25 * xi * ( 1 + xi ) * ( 1 + 2*eta ) - !dphideta(2) = - 0.25 * xi * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(3) = 0.25 * xi * ( 1 - xi ) * ( 1 - 2*eta ) - !dphideta(4) = - 0.25 * xi * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(6) = xi * ( 1 - xi ) * eta - !dphideta(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(8) = - xi * ( 1 + xi ) * eta - !dphideta(9) = - 2 * ( 1 - xi ) * ( 1 + xi ) * eta - -end subroutine evaluate_shape_quadratic -! ============================================================================== - -!> This subroutine calculates integrals of specific volume anomalies in -!! pressure across layers, which are required for calculating the finite-volume -!! form pressure accelerations in a non-Boussinesq model. There are essentially -!! no free assumptions, apart from the use of Bode's rule quadrature to do the integrals. -subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, dza, & - intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T !< Potential temperature of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity of the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] - real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] - !! The calculation is mathematically identical with different values of - !! alpha_ref, but alpha_ref alters the effects of roundoff, and - !! answers do change. - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of - !! the geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: intx_dza !< The integral in x of the difference between - !! the geopotential anomaly at the top and bottom of the layer divided - !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: inty_dza !< The integral in y of the difference between - !! the geopotential anomaly at the top and bottom of the layer divided - !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] - integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] - real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. - -! This subroutine calculates analytical and nearly-analytical integrals in -! pressure across layers of geopotential anomalies, which are required for -! calculating the finite-volume form pressure accelerations in a non-Boussinesq -! model. There are essentially no free assumptions, apart from the use of -! Bode's rule to do the horizontal integrals, and from a truncation in the -! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. - - ! Local variables - real :: T5(5) ! Temperatures at five quadrature points [degC] - real :: S5(5) ! Salinities at five quadrature points [ppt] - real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa if necessary [Pa] - real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] - real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] - real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] - real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] - real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] - real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] - real :: intp(5) ! The integrals of specific volume with pressure at the - ! 5 sub-column locations [L2 T-2 ~> m2 s-2] - real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] - real :: SV_scale ! A multiplicative factor by which to scale specific - ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] - logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. - integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) - ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo - if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif - if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - - SV_scale = EOS%R_to_kg_m3 - RL2_T2_to_Pa = EOS%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R - - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "bathyP must be present if useMassWghtInterp is present and true.") - if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif - - do j=jsh,jeh ; do i=ish,ieh - dp = p_b(i,j) - p_t(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) - enddo - - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) - endif - - ! Use Bode's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo - - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i+1,j)) - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) - - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - RL2_T2_to_Pa * 0.25*dp - enddo - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) - endif - - ! Use Bode's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif - - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i,j+1)) - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) - enddo - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) - endif - - ! Use Bode's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in y. - inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif - -end subroutine int_spec_vol_dp_generic - -!> This subroutine calculates integrals of specific volume anomalies in -!! pressure across layers, which are required for calculating the finite-volume -!! form pressure accelerations in a non-Boussinesq model. There are essentially -!! no free assumptions, apart from the use of Bode's rule quadrature to do the integrals. -subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & - dP_neglect, bathyP, HI, EOS, dza, & - intp_dza, intx_dza, inty_dza, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_t !< Potential temperature at the top of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_t !< Salinity at the top the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the bottom the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] - real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] - !! The calculation is mathematically identical with different values of - !! alpha_ref, but alpha_ref alters the effects of roundoff, and - !! answers do change. - real, intent(in) :: dP_neglect ! Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [L2 T-2 ~> m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of - !! the geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: intx_dza !< The integral in x of the difference between - !! the geopotential anomaly at the top and bottom of the layer divided - !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: inty_dza !< The integral in y of the difference between - !! the geopotential anomaly at the top and bottom of the layer divided - !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. - -! This subroutine calculates analytical and nearly-analytical integrals in -! pressure across layers of geopotential anomalies, which are required for -! calculating the finite-volume form pressure accelerations in a non-Boussinesq -! model. There are essentially no free assumptions, apart from the use of -! Bode's rule to do the horizontal integrals, and from a truncation in the -! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. - - real :: T5(5) ! Temperatures at five quadrature points [degC] - real :: S5(5) ! Salinities at five quadrature points [ppt] - real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa as necessary [Pa] - real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: T15(15) ! Temperatures at fifteen interior quadrature points [degC] - real :: S15(15) ! Salinities at fifteen interior quadrature points [ppt] - real :: p15(15) ! Pressures at fifteen quadrature points, scaled back to Pa as necessary [Pa] - real :: a15(15) ! Specific volumes at fifteen quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] - real :: T_top, T_bot, S_top, S_bot, P_top, P_bot - - real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1] - real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] - real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] - real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] - real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] - real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] - real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] - real :: intp(5) ! The integrals of specific volume with pressure at the - ! 5 sub-column locations [L2 T-2 ~> m2 s-2] - real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] - real :: SV_scale ! A multiplicative factor by which to scale specific - ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. - logical :: do_massWeight ! Indicates whether to do mass weighting. - integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - - do_massWeight = .false. - if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp - - SV_scale = EOS%R_to_kg_m3 - RL2_T2_to_Pa = EOS%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R - - do n = 1, 5 ! Note that these are reversed from int_density_dz. - wt_t(n) = 0.25 * real(n-1) - wt_b(n) = 1.0 - wt_t(n) - enddo - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1; do i=Isq,Ieq+1 - dp = p_b(i,j) - p_t(i,j) - do n=1,5 ! T, S and p are linearly interpolated in the vertical. - p5(n) = RL2_T2_to_Pa * (wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j)) - S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) - T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) - enddo - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) - endif - - ! Use Bode's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. Note: To work in terrain following coordinates we could - ! offset this distance by the layer thickness to replicate other models. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) - S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot - T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot - enddo - enddo - - if (SV_scale /= 1.0) then - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - ! Use Bode's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, like thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) - S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot - T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot - enddo - enddo - - if (SV_scale /= 1.0) then - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - ! Use Bode's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif - -end subroutine int_spec_vol_dp_generic_plm !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) @@ -2934,6 +1560,14 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 +!> Return value of EOS_quadrature +logical function EOS_quadrature(EOS) + type(EOS_type), pointer :: EOS !< Equation of state structure + + EOS_quadrature = EOS%EOS_quadrature + +end function EOS_quadrature + !> Extractor routine for the EOS type if the members need to be accessed outside this module subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index e3a5443840..47a2bf21b0 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -473,7 +473,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR diff --git a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 deleted file mode 100644 index ca1ac55956..0000000000 --- a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 +++ /dev/null @@ -1,82 +0,0 @@ -!========================================================================== -elemental function gsw_chem_potential_water_t_exact (sa, t, p) -!========================================================================== -! -! Calculates the chemical potential of water in seawater. -! -! SA = Absolute Salinity [ g/kg ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! chem_potential_water_t_exact = chemical potential of water in seawater -! [ J/g ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_chem_potential_water_t_exact - -real (r8) :: g03_g, g08_g, g_sa_part, x, x2, y, z - -real (r8), parameter :: kg2g = 1e-3_r8 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -g03_g = 101.342743139674_r8 + z*(100015.695367145_r8 + & - z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & - z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & - y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & - z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & - y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & - z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & - y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & - z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & - y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & - z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & - y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & - z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) - -g08_g = x2*(1416.27648484197_r8 + & - x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & - y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & - y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & - x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & - x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & - z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & - z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & - y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & - y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & - y*(168.072408311545_r8)) - -g_sa_part = 8645.36753595126_r8 + & - x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & - z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & - y*(1187.3715515697959_r8) - -gsw_chem_potential_water_t_exact = kg2g*(g03_g + g08_g - 0.5_r8*x2*g_sa_part) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 new file mode 120000 index 0000000000..7ce7ff9e1e --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_chem_potential_water_t_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 deleted file mode 100644 index 1627322dcd..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 +++ /dev/null @@ -1,43 +0,0 @@ -!========================================================================== -elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the Conservative Temperature at which seawater freezes. The -! Conservative Temperature freezing point is calculated from the exact -! in-situ freezing temperature which is found by a modified Newton-Raphson -! iteration (McDougall and Wotherspoon, 2013) of the equality of the -! chemical potentials of water in seawater and in ice. -! -! An alternative GSW function, gsw_CT_freezing_poly, it is based on a -! computationally-efficient polynomial, and is accurate to within -5e-4 K -! and 6e-4 K, when compared with this function. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_t_freezing_exact -use gsw_mod_toolbox, only : gsw_ct_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_ct_freezing_exact - -real (r8) :: t_freezing - -t_freezing = gsw_t_freezing_exact(sa,p,saturation_fraction) -gsw_ct_freezing_exact = gsw_ct_from_t(sa,t_freezing,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 new file mode 120000 index 0000000000..696fe5c425 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_freezing_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 deleted file mode 100644 index a6b8f08091..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 +++ /dev/null @@ -1,53 +0,0 @@ -!========================================================================== -elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the Conservative Temperature at which seawater freezes. -! The error of this fit ranges between -5e-4 K and 6e-4 K when compared -! with the Conservative Temperature calculated from the exact in-situ -! freezing temperature which is found by a Newton-Raphson iteration of the -! equality of the chemical potentials of water in seawater and in ice. -! Note that the Conservative temperature freezing temperature can be found -! by this exact method using the function gsw_CT_freezing. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] -! That is, the freezing temperature expressed in -! terms of Conservative Temperature (ITS-90). -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_freezing_poly_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_ct_freezing_poly - -real (r8) :: p_r, sa_r, x - -sa_r = sa*1e-2_r8 -x = sqrt(sa_r) -p_r = p*1e-4_r8 - -gsw_ct_freezing_poly = c0 & - + sa_r*(c1 + x*(c2 + x*(c3 + x*(c4 + x*(c5 + c6*x))))) & - + p_r*(c7 + p_r*(c8 + c9*p_r)) + sa_r*p_r*(c10 + p_r*(c12 & - + p_r*(c15 + c21*sa_r)) + sa_r*(c13 + c17*p_r + c19*sa_r) & - + x*(c11 + p_r*(c14 + c18*p_r) + sa_r*(c16 + c20*p_r + c22*sa_r))) - -! Adjust for the effects of dissolved air -gsw_ct_freezing_poly = gsw_ct_freezing_poly - saturation_fraction* & - (1e-3_r8)*(2.4_r8 - a*sa)*(1.0_r8 + b*(1.0_r8 - sa/gsw_sso)) - -return -end function diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 new file mode 120000 index 0000000000..84e6e12572 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_freezing_poly.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 deleted file mode 100644 index c4a624ed37..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 +++ /dev/null @@ -1,52 +0,0 @@ -!========================================================================== -elemental function gsw_ct_from_pt (sa, pt) -!========================================================================== -! -! Calculates Conservative Temperature from potential temperature of seawater -! -! sa : Absolute Salinity [g/kg] -! pt : potential temperature with [deg C] -! reference pressure of 0 dbar -! -! gsw_ct_from_pt : Conservative Temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt - -real (r8) :: gsw_ct_from_pt - -real (r8) :: pot_enthalpy, x2, x, y - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt*0.025_r8 ! normalize for F03 and F08 - -pot_enthalpy = 61.01362420681071_r8 + y*(168776.46138048015_r8 + & - y*(-2735.2785605119625_r8 + y*(2574.2164453821433_r8 + & - y*(-1536.6644434977543_r8 + y*(545.7340497931629_r8 + & - (-50.91091728474331_r8 - 18.30489878927802_r8*y)*y))))) + & - x2*(268.5520265845071_r8 + y*(-12019.028203559312_r8 + & - y*(3734.858026725145_r8 + y*(-2046.7671145057618_r8 + & - y*(465.28655623826234_r8 + (-0.6370820302376359_r8 - & - 10.650848542359153_r8*y)*y)))) + & - x*(937.2099110620707_r8 + y*(588.1802812170108_r8 + & - y*(248.39476522971285_r8 + (-3.871557904936333_r8 - & - 2.6268019854268356_r8*y)*y)) + & - x*(-1687.914374187449_r8 + x*(246.9598888781377_r8 + & - x*(123.59576582457964_r8 - 48.5891069025409_r8*x)) + & - y*(936.3206544460336_r8 + & - y*(-942.7827304544439_r8 + y*(369.4389437509002_r8 + & - (-33.83664947895248_r8 - 9.987880382780322_r8*y)*y)))))) - -gsw_ct_from_pt = pot_enthalpy/gsw_cp0 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 new file mode 120000 index 0000000000..d67d2df3e2 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_from_pt.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 deleted file mode 100644 index b2a0c9e354..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 +++ /dev/null @@ -1,32 +0,0 @@ -!========================================================================== -elemental function gsw_ct_from_t (sa, t, p) -!========================================================================== -! -! Calculates Conservative Temperature from in-situ temperature -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_ct_from_t : Conservative Temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_pt0_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_ct_from_t - -real (r8) :: pt0 - -pt0 = gsw_pt0_from_t(sa,t,p) -gsw_ct_from_t = gsw_ct_from_pt(sa,pt0) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 new file mode 120000 index 0000000000..6f917027b3 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 deleted file mode 100644 index 70fcd11255..0000000000 --- a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 +++ /dev/null @@ -1,62 +0,0 @@ -!========================================================================== -elemental function gsw_entropy_part (sa, t, p) -!========================================================================== -! -! entropy minus the terms that are a function of only SA -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_entropy_part : entropy part -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_entropy_part - -real (r8) :: x2, x, y, z, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -g03 = z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) - -g08 = x2*(z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - x*( x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & - z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & - z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - -gsw_entropy_part = -(g03 + g08)*0.025_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 new file mode 120000 index 0000000000..0160db551f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_entropy_part.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 deleted file mode 100644 index 2156b71c4e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 +++ /dev/null @@ -1,44 +0,0 @@ -!========================================================================== -elemental function gsw_entropy_part_zerop (sa, pt0) -!========================================================================== -! -! entropy part evaluated at the sea surface -! -! sa : Absolute Salinity [g/kg] -! pt0 : insitu temperature [deg C] -! -! gsw_entropy_part_zerop : entropy part at the sea surface -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt0 - -real (r8) :: gsw_entropy_part_zerop - -real (r8) :: x2, x, y, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt0*0.025_r8 - -g03 = y*(-24715.571866078_r8 + y*(2210.2236124548363_r8 + & - y*(-592.743745734632_r8 + y*(290.12956292128547_r8 + & - y*(-113.90630790850321_r8 + y*21.35571525415769_r8))))) - -g08 = x2*(x*(x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & - y*(-68.5590309679152_r8 + 12.4848504784754_r8*y)))) + & - y*(-86.1329351956084_r8 + y*(-30.0682112585625_r8 + y*3.50240264723578_r8))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y))))) - -gsw_entropy_part_zerop = -(g03 + g08)*0.025_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 new file mode 120000 index 0000000000..678bce8822 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_entropy_part_zerop.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs.f90 b/src/equation_of_state/TEOS10/gsw_gibbs.f90 deleted file mode 100644 index 59f7d221ac..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs.f90 +++ /dev/null @@ -1,317 +0,0 @@ -!========================================================================== -elemental function gsw_gibbs (ns, nt, np, sa, t, p) -!========================================================================== -! -! seawater specific Gibbs free energy and derivatives up to order 2 -! -! ns : order of s derivative -! nt : order of t derivative -! np : order of p derivative -! sa : Absolute Salinity [g/kg] -! t : temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_gibbs : specific Gibbs energy or its derivative -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -integer, intent(in) :: ns, nt, np -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_gibbs - -real (r8) :: x2, x, y, z, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -if(ns.eq.0 .and. nt.eq.0 .and. np.eq.0) then - - g03 = 101.342743139674_r8 + z*(100015.695367145_r8 + & - z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & - z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & - y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & - z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & - y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & - z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & - y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & - z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & - y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & - z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & - y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & - z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) - - g08 = x2*(1416.27648484197_r8 + z*(-3310.49154044839_r8 + & - z*(384.794152978599_r8 + z*(-96.5324320107458_r8 + (15.8408172766824_r8 - 2.62480156590992_r8*z)*z))) + & - x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & - y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & - y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & - x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & - x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & - z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & - z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & - y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & - y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & - y*(168.072408311545_r8 + z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - y*(880.031352997204_r8 + y*(-225.267649263401_r8 + & - y*(91.4260447751259_r8 + y*(-21.6603240875311_r8 + 2.13016970847183_r8*y) + & - z*(-297.728741987187_r8 + (74.726141138756_r8 - 36.4872919001588_r8*z)*z)) + & - z*(694.244814133268_r8 + z*(-204.889641964903_r8 + (113.561697840594_r8 - 11.1282734326413_r8*z)*z))) + & - z*(-860.764303783977_r8 + z*(337.409530269367_r8 + & - z*(-178.314556207638_r8 + (44.2040358308_r8 - 7.92001547211682_r8*z)*z)))))) - - if(sa.gt.0.0_r8) & - g08 = g08 + x2*(5812.81456626732_r8 + 851.226734946706_r8*y)*log(x) - - gsw_gibbs = g03 + g08 - -elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.0) then - - g08 = 8645.36753595126_r8 + z*(-6620.98308089678_r8 + & - z*(769.588305957198_r8 + z*(-193.0648640214916_r8 + (31.6816345533648_r8 - 5.24960313181984_r8*z)*z))) + & - x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & - z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & - y*(1187.3715515697959_r8 + z*(1458.233059470092_r8 + & - z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-450.535298526802_r8 + & - y*(182.8520895502518_r8 + y*(-43.3206481750622_r8 + 4.26033941694366_r8*y) + & - z*(-595.457483974374_r8 + (149.452282277512_r8 - 72.9745838003176_r8*z)*z)) + & - z*(1388.489628266536_r8 + z*(-409.779283929806_r8 + (227.123395681188_r8 - 22.2565468652826_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - - if(sa.gt.0_r8) then - g08 = g08 + (11625.62913253464_r8 + 1702.453469893412_r8*y)*log(x) - else - g08 = 0.0_r8 - endif - - gsw_gibbs = 0.5*gsw_sfac*g08 - -elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.0) then - - g03 = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) - - g08 = x2*(168.072408311545_r8 + z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - x*(-493.407510141682_r8 + x*(543.835333000098_r8 + x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & - y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & - z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & - z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - - if(sa.gt.0_r8) g08 = g08 + 851.226734946706_r8*x2*log(x) - - gsw_gibbs = (g03 + g08)*0.025_r8 - -elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.1) then - - g03 = 100015.695367145_r8 + z*(-5089.1530840726_r8 + & - z*(853.5533353388611_r8 + z*(-133.2587017014444_r8 + (21.0131554401542_r8 - 3.278571068826234_r8*z)*z))) + & - y*(-270.983805184062_r8 + z*(1552.307223226202_r8 + & - z*(-589.53765264366_r8 + (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & - y*(1455.0364540468_r8 + z*(-1513.116771538718_r8 + & - z*(820.438986970584_r8 + z*(-222.2416255268872_r8 + 21.72103359585985_r8*z))) + & - y*(-672.50778314507_r8 + z*(998.720781638304_r8 + & - z*(-718.6359919632359_r8 + (195.2050074375488_r8 - 8.31535531044525_r8*z)*z)) + & - y*(397.968445406972_r8 + z*(-603.630761243752_r8 + (456.589115201523_r8 - 105.4993508931208_r8*z)*z) + & - y*(-194.618310617595_r8 + y*(63.5113936641785_r8 - 9.63108119393062_r8*y + & - z*(-44.5794634280918_r8 + 24.511816254543362_r8*z)) + & - z*(241.04130980405_r8 + z*(-165.8169157020456_r8 + & - 25.92762672308884_r8*z))))))) - - g08 = x2*(-3310.49154044839_r8 + z*(769.588305957198_r8 + & - z*(-289.5972960322374_r8 + (63.3632691067296_r8 - 13.1240078295496_r8*z)*z)) + & - x*(199.459603073901_r8 + x*(-54.7919133532887_r8 + 36.0284195611086_r8*x - 22.6683558512829_r8*y + & - (-8.16387957824522_r8 - 90.52653359134831_r8*z)*z) + & - z*(-104.588181856267_r8 + (204.1334828179377_r8 - 13.65007729765128_r8*z)*z) + & - y*(-175.292041186547_r8 + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & - y*(383.058066002476_r8 + y*(-460.319931801257_r8 + 234.565187611355_r8*y) + & - z*(-108.3834525034224_r8 + 76.9195462169742_r8*z)))) + & - y*(729.116529735046_r8 + z*(-687.913805923122_r8 + & - z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & - y*(-860.764303783977_r8 + y*(694.244814133268_r8 + & - y*(-297.728741987187_r8 + (149.452282277512_r8 - 109.46187570047641_r8*z)*z) + & - z*(-409.779283929806_r8 + (340.685093521782_r8 - 44.5130937305652_r8*z)*z)) + & - z*(674.819060538734_r8 + z*(-534.943668622914_r8 + (176.8161433232_r8 - 39.600077360584095_r8*z)*z))))) - - gsw_gibbs = (g03 + g08)*1e-8_r8 - -elseif(ns.eq.0 .and. nt.eq.2 .and. np.eq.0) then - - g03 = -24715.571866078_r8 + z*(2910.0729080936_r8 + z* & - (-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(4420.4472249096725_r8 + z*(-4035.04669887042_r8 + & - z*(2996.162344914912_r8 + z*(-1437.2719839264719_r8 + (292.8075111563232_r8 - 9.978426372534301_r8*z)*z))) + & - y*(-1778.231237203896_r8 + z*(4775.621344883664_r8 + & - z*(-3621.784567462512_r8 + (1826.356460806092_r8 - 316.49805267936244_r8*z)*z)) + & - y*(1160.5182516851419_r8 + z*(-3892.3662123519_r8 + & - z*(2410.4130980405_r8 + z*(-1105.446104680304_r8 + 129.6381336154442_r8*z))) + & - y*(-569.531539542516_r8 + y*(128.13429152494615_r8 - 404.50541014508605_r8*z) + & - z*(1905.341809925355_r8 + z*(-668.691951421377_r8 + 245.11816254543362_r8*z)))))) - - g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & - x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & - z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-60.136422517125_r8 - 2761.9195908075417_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z))) + & - y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + y*(-433.20648175062206_r8 + 63.905091254154904_r8*y) + & - z*(-3572.7449038462437_r8 + (896.713693665072_r8 - 437.84750280190565_r8*z)*z)) + & - z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*0.000625_r8 - -elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.1) then - - g08 = -6620.98308089678_r8 + z*(1539.176611914396_r8 + & - z*(-579.1945920644748_r8 + (126.7265382134592_r8 - 26.2480156590992_r8*z)*z)) + & - x*(598.378809221703_r8 + x*(-219.1676534131548_r8 + 180.142097805543_r8*x - 90.6734234051316_r8*y + & - (-32.65551831298088_r8 - 362.10613436539325_r8*z)*z) + & - z*(-313.764545568801_r8 + (612.4004484538132_r8 - 40.95023189295384_r8*z)*z) + & - y*(-525.876123559641_r8 + (499.15435668109143_r8 - 265.347579144861_r8*z)*z + & - y*(1149.174198007428_r8 + y*(-1380.9597954037708_r8 + 703.695562834065_r8*y) + & - z*(-325.1503575102672_r8 + 230.7586386509226_r8*z)))) + & - y*(1458.233059470092_r8 + z*(-1375.827611846244_r8 + & - z*(748.126026697488_r8 + z*(-253.255715088584_r8 + 70.4658803315449_r8*z))) + & - y*(-1721.528607567954_r8 + y*(1388.489628266536_r8 + & - y*(-595.457483974374_r8 + (298.904564555024_r8 - 218.92375140095282_r8*z)*z) + & - z*(-819.558567859612_r8 + (681.370187043564_r8 - 89.0261874611304_r8*z)*z)) + & - z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) - - gsw_gibbs = g08*gsw_sfac*0.5e-8_r8 - -elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.1) then - - g03 = -270.983805184062_r8 + z*(1552.307223226202_r8 + z*(-589.53765264366_r8 + & - (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & - y*(2910.0729080936_r8 + z*(-3026.233543077436_r8 + & - z*(1640.877973941168_r8 + z*(-444.4832510537744_r8 + 43.4420671917197_r8*z))) + & - y*(-2017.52334943521_r8 + z*(2996.162344914912_r8 + & - z*(-2155.907975889708_r8 + (585.6150223126464_r8 - 24.946065931335752_r8*z)*z)) + & - y*(1591.873781627888_r8 + z*(-2414.523044975008_r8 + (1826.356460806092_r8 - 421.9974035724832_r8*z)*z) + & - y*(-973.091553087975_r8 + z*(1205.20654902025_r8 + z*(-829.084578510228_r8 + 129.6381336154442_r8*z)) + & - y*(381.06836198507096_r8 - 67.41756835751434_r8*y + z*(-267.4767805685508_r8 + 147.07089752726017_r8*z)))))) - - g08 = x2*(729.116529735046_r8 + z*(-687.913805923122_r8 + & - z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & - x*(-175.292041186547_r8 - 22.6683558512829_r8*x + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & - y*(766.116132004952_r8 + y*(-1380.9597954037708_r8 + 938.26075044542_r8*y) + & - z*(-216.7669050068448_r8 + 153.8390924339484_r8*z))) + & - y*(-1721.528607567954_r8 + y*(2082.7344423998043_r8 + & - y*(-1190.914967948748_r8 + (597.809129110048_r8 - 437.84750280190565_r8*z)*z) + & - z*(-1229.337851789418_r8 + (1022.055280565346_r8 - 133.5392811916956_r8*z)*z)) + & - z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*2.5e-10_r8 - -elseif(ns.eq.1 .and. nt.eq.1 .and. np.eq.0) then - - g08 = 1187.3715515697959_r8 + z*(1458.233059470092_r8 + & - z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & - x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & - y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & - 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & - y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) + & - y*(3520.125411988816_r8 + y*(-1351.605895580406_r8 + & - y*(731.4083582010072_r8 + y*(-216.60324087531103_r8 + 25.56203650166196_r8*y) + & - z*(-2381.829935897496_r8 + (597.809129110048_r8 - 291.8983352012704_r8*z)*z)) + & - z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & - z*(-3443.057215135908_r8 + z*(1349.638121077468_r8 + & - z*(-713.258224830552_r8 + (176.8161433232_r8 - 31.68006188846728_r8*z)*z)))) - - if(sa.gt.0_r8) g08 = g08 + 1702.453469893412_r8*log(x) - - gsw_gibbs = 0.5_r8*gsw_sfac*0.025_r8*g08 - -elseif(ns.eq.2 .and. nt.eq.0 .and. np.eq.0) then - - g08 = 2.0_r8*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - 1.5_r8*x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - (4.0_r8/3.0_r8)*x*(2247.60742726704_r8 - 340.1237483177863_r8*1.25_r8*x + 220.542973797483_r8*y) + & - 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) - - if (x.gt.0_r8) then - g08 = g08 + (-7296.43987145382_r8 + z*(598.378809221703_r8 + & - z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + & - (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + & - z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & - y*(2.626801985426835_r8 + 703.695562834065_r8*z)))))/x + & - (11625.62913253464_r8 + 1702.453469893412_r8*y)/x2 - else - g08 = 0.0_r8 - end if - - gsw_gibbs = 0.25_r8*gsw_sfac*gsw_sfac*g08 - -elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.2) then - - g03 = -5089.1530840726_r8 + z*(1707.1066706777221_r8 + & - z*(-399.7761051043332_r8 + (84.0526217606168_r8 - 16.39285534413117_r8*z)*z)) + & - y*(1552.307223226202_r8 + z*(-1179.07530528732_r8 + (347.75583155301_r8 - 42.658016703665396_r8*z)*z) + & - y*(-1513.116771538718_r8 + z*(1640.877973941168_r8 + z*(-666.7248765806615_r8 + 86.8841343834394_r8*z)) + & - y*(998.720781638304_r8 + z*(-1437.2719839264719_r8 + (585.6150223126464_r8 - 33.261421241781_r8*z)*z) + & - y*(-603.630761243752_r8 + (913.178230403046_r8 - 316.49805267936244_r8*z)*z + & - y*(241.04130980405_r8 + y*(-44.5794634280918_r8 + 49.023632509086724_r8*z) + & - z*(-331.6338314040912_r8 + 77.78288016926652_r8*z)))))) - - g08 = x2*(769.588305957198_r8 + z*(-579.1945920644748_r8 + (190.08980732018878_r8 - 52.4960313181984_r8*z)*z) + & - x*(-104.588181856267_r8 + x*(-8.16387957824522_r8 - 181.05306718269662_r8*z) + & - (408.2669656358754_r8 - 40.95023189295384_r8*z)*z + & - y*(166.3847855603638_r8 - 176.898386096574_r8*z + y*(-108.3834525034224_r8 + 153.8390924339484_r8*z))) + & - y*(-687.913805923122_r8 + z*(748.126026697488_r8 + z*(-379.883572632876_r8 + 140.9317606630898_r8*z)) + & - y*(674.819060538734_r8 + z*(-1069.887337245828_r8 + (530.4484299696_r8 - 158.40030944233638_r8*z)*z) + & - y*(-409.779283929806_r8 + y*(149.452282277512_r8 - 218.92375140095282_r8*z) + & - (681.370187043564_r8 - 133.5392811916956_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*1e-16_r8 - -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs.f90 b/src/equation_of_state/TEOS10/gsw_gibbs.f90 new file mode 120000 index 0000000000..6bb64d98a7 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 deleted file mode 100644 index 0416a1eeaf..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 +++ /dev/null @@ -1,130 +0,0 @@ -! ========================================================================= -elemental function gsw_gibbs_ice (nt, np, t, p) -! ========================================================================= -! -! Ice specific Gibbs energy and derivatives up to order 2. -! -! nt = order of t derivative [ integers 0, 1 or 2 ] -! np = order of p derivative [ integers 0, 1 or 2 ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! -! gibbs_ice = Specific Gibbs energy of ice or its derivatives. -! The Gibbs energy (when nt = np = 0) has units of: [ J/kg ] -! The temperature derivatives are output in units of: -! [ (J/kg) (K)^(-nt) ] -! The pressure derivatives are output in units of: -! [ (J/kg) (Pa)^(-np) ] -! The mixed derivatives are output in units of: -! [ (J/kg) (K)^(-nt) (Pa)^(-np) ] -! Note. The derivatives are taken with respect to pressure in Pa, not -! withstanding that the pressure input into this routine is in dbar. -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_t0, db2pa - -use gsw_mod_gibbs_ice_coefficients - -use gsw_mod_kinds - -implicit none - -integer, intent(in) :: nt, np -real (r8), intent(in) :: t, p - -real (r8) :: gsw_gibbs_ice - -real (r8) :: dzi, g0, g0p, g0pp, sqrec_pt -complex (r8) :: r2, r2p, r2pp, g, sqtau_t1, sqtau_t2, tau, tau_t1, tau_t2 - -real (r8), parameter :: s0 = -3.32733756492168e3_r8 - -tau = (t + gsw_t0)*rec_tt - -dzi = db2pa*p*rec_pt - -if (nt.eq.0 .and. np.eq.0) then - - tau_t1 = tau/t1 - sqtau_t1 = tau_t1*tau_t1 - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0 = g00 + dzi*(g01 + dzi*(g02 + dzi*(g03 + g04*dzi))) - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(tau*log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) & - + t1*(log(1.0_r8 - sqtau_t1) - sqtau_t1)) & - + r2*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0 - tt*(s0*tau - real(g)) - -elseif (nt.eq.1 .and. np.eq.0) then - - tau_t1 = tau/t1 - tau_t2 = tau/t2 - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) - 2.0_r8*tau_t1) & - + r2*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) - - gsw_gibbs_ice = -s0 + real(g) - -elseif (nt.eq.0 .and. np.eq.1) then - - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0p = rec_pt*(g01 + dzi*(2.0_r8*g02 + dzi*(3.0_r8*g03 + 4.0_r8*g04*dzi))) - - r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) - - g = r2p*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0p + tt*real(g) - -elseif (nt.eq.1 .and. np.eq.1) then - - tau_t2 = tau/t2 - - r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) - - g = r2p*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) - - gsw_gibbs_ice = real(g) - -elseif (nt.eq.2 .and. np.eq.0) then - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(1.0_r8/(t1 - tau) + 1.0_r8/(t1 + tau) - 2.0_r8/t1) & - + r2*(1.0_r8/(t2 - tau) + 1.0_r8/(t2 + tau) - 2.0_r8/t2) - - gsw_gibbs_ice = rec_tt*real(g) - -elseif (nt.eq.0 .and. np.eq.2) then - - sqrec_pt = rec_pt*rec_pt - - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0pp = sqrec_pt*(2.0_r8*g02 + dzi*(6.0_r8*g03 + 12.0_r8*g04*dzi)) - - r2pp = 2.0_r8*r22*sqrec_pt - - g = r2pp*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0pp + tt*real(g) - -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 new file mode 120000 index 0000000000..9d1d06c481 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs_ice.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 deleted file mode 100644 index 6e8bcfc779..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 +++ /dev/null @@ -1,47 +0,0 @@ -!========================================================================== -elemental function gsw_gibbs_pt0_pt0 (sa, pt0) -!========================================================================== -! -! gibbs_tt at (sa,pt,0) -! -! sa : Absolute Salinity [g/kg] -! pt0 : potential temperature [deg C] -! -! gsw_gibbs_pt0_pt0 : gibbs_tt at (sa,pt,0) -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt0 - -real (r8) :: gsw_gibbs_pt0_pt0 - -real (r8) :: x2, x, y, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt0*0.025_r8 - -g03 = -24715.571866078_r8 + & - y*(4420.4472249096725_r8 + & - y*(-1778.231237203896_r8 + & - y*(1160.5182516851419_r8 + & - y*(-569.531539542516_r8 + y*128.13429152494615_r8)))) - -g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & - x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + & - y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & - y*(-60.136422517125_r8 + y*10.50720794170734_r8)) + & - y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + & - y*(-433.20648175062206_r8 + 63.905091254154904_r8*y)))) - -gsw_gibbs_pt0_pt0 = (g03 + g08)*0.000625_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 new file mode 120000 index 0000000000..e345379f5d --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs_pt0_pt0.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 deleted file mode 100644 index d4b5052f99..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 +++ /dev/null @@ -1,63 +0,0 @@ -!========================================================================== -module gsw_mod_freezing_poly_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: c0 = 0.017947064327968736_r8 -real (r8), parameter :: c1 = -6.076099099929818_r8 -real (r8), parameter :: c2 = 4.883198653547851_r8 -real (r8), parameter :: c3 = -11.88081601230542_r8 -real (r8), parameter :: c4 = 13.34658511480257_r8 -real (r8), parameter :: c5 = -8.722761043208607_r8 -real (r8), parameter :: c6 = 2.082038908808201_r8 -real (r8), parameter :: c7 = -7.389420998107497_r8 -real (r8), parameter :: c8 = -2.110913185058476_r8 -real (r8), parameter :: c9 = 0.2295491578006229_r8 -real (r8), parameter :: c10 = -0.9891538123307282_r8 -real (r8), parameter :: c11 = -0.08987150128406496_r8 -real (r8), parameter :: c12 = 0.3831132432071728_r8 -real (r8), parameter :: c13 = 1.054318231187074_r8 -real (r8), parameter :: c14 = 1.065556599652796_r8 -real (r8), parameter :: c15 = -0.7997496801694032_r8 -real (r8), parameter :: c16 = 0.3850133554097069_r8 -real (r8), parameter :: c17 = -2.078616693017569_r8 -real (r8), parameter :: c18 = 0.8756340772729538_r8 -real (r8), parameter :: c19 = -2.079022768390933_r8 -real (r8), parameter :: c20 = 1.596435439942262_r8 -real (r8), parameter :: c21 = 0.1338002171109174_r8 -real (r8), parameter :: c22 = 1.242891021876471_r8 - -! Note that a = 0.502500117621_r8/gsw_sso -real (r8), parameter :: a = 0.014289763856964_r8 -real (r8), parameter :: b = 0.057000649899720_r8 - -real (r8), parameter :: t0 = 0.002519_r8 -real (r8), parameter :: t1 = -5.946302841607319_r8 -real (r8), parameter :: t2 = 4.136051661346983_r8 -real (r8), parameter :: t3 = -1.115150523403847e1_r8 -real (r8), parameter :: t4 = 1.476878746184548e1_r8 -real (r8), parameter :: t5 = -1.088873263630961e1_r8 -real (r8), parameter :: t6 = 2.961018839640730_r8 -real (r8), parameter :: t7 = -7.433320943962606_r8 -real (r8), parameter :: t8 = -1.561578562479883_r8 -real (r8), parameter :: t9 = 4.073774363480365e-2_r8 -real (r8), parameter :: t10 = 1.158414435887717e-2_r8 -real (r8), parameter :: t11 = -4.122639292422863e-1_r8 -real (r8), parameter :: t12 = -1.123186915628260e-1_r8 -real (r8), parameter :: t13 = 5.715012685553502e-1_r8 -real (r8), parameter :: t14 = 2.021682115652684e-1_r8 -real (r8), parameter :: t15 = 4.140574258089767e-2_r8 -real (r8), parameter :: t16 = -6.034228641903586e-1_r8 -real (r8), parameter :: t17 = -1.205825928146808e-2_r8 -real (r8), parameter :: t18 = -2.812172968619369e-1_r8 -real (r8), parameter :: t19 = 1.877244474023750e-2_r8 -real (r8), parameter :: t20 = -1.204395563789007e-1_r8 -real (r8), parameter :: t21 = 2.349147739749606e-1_r8 -real (r8), parameter :: t22 = 2.748444541144219e-3_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 new file mode 120000 index 0000000000..93ea8e1d2a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_freezing_poly_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 deleted file mode 100644 index e9da3baf48..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -module gsw_mod_gibbs_ice_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -complex(r8), parameter :: t1 =( 3.68017112855051e-2_r8, 5.10878114959572e-2_r8) -complex(r8), parameter :: t2 =( 3.37315741065416e-1_r8, 3.35449415919309e-1_r8) - -complex(r8), parameter :: r1 =( 4.47050716285388e1_r8, 6.56876847463481e1_r8) -complex(r8), parameter :: r20=(-7.25974574329220e1_r8, -7.81008427112870e1_r8) -complex(r8), parameter :: r21=(-5.57107698030123e-5_r8, 4.64578634580806e-5_r8) -complex(r8), parameter :: r22=(2.34801409215913e-11_r8,-2.85651142904972e-11_r8) - -! 1./Pt, where Pt = 611.657; Experimental triple-point pressure in Pa. -real (r8), parameter :: rec_pt = 1.634903221903779e-3_r8 -real (r8), parameter :: tt = 273.16_r8 ! Triple-point temperature, kelvin (K). -real (r8), parameter :: rec_tt = 3.660858105139845e-3_r8 ! = 1/tt - -real (r8), parameter :: g00 = -6.32020233335886e5_r8 -real (r8), parameter :: g01 = 6.55022213658955e-1_r8 -real (r8), parameter :: g02 = -1.89369929326131e-8_r8 -real (r8), parameter :: g03 = 3.3974612327105304e-15_r8 -real (r8), parameter :: g04 = -5.564648690589909e-22_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 new file mode 120000 index 0000000000..4c72d9079b --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_gibbs_ice_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 deleted file mode 100644 index 7a2a80891f..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 +++ /dev/null @@ -1,16 +0,0 @@ -!========================================================================== -module gsw_mod_kinds -!========================================================================== - -implicit none - -integer, parameter :: r4 = selected_real_kind(6,30) - -integer, parameter :: r8 = selected_real_kind(14,30) - -end module - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 new file mode 120000 index 0000000000..fa0926e540 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_kinds.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 deleted file mode 100644 index 7bc89c7b5e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 +++ /dev/null @@ -1,313 +0,0 @@ -!========================================================================== -module gsw_mod_specvol_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: a000 = -1.56497346750e-5_r8 -real (r8), parameter :: a001 = 1.85057654290e-5_r8 -real (r8), parameter :: a002 = -1.17363867310e-6_r8 -real (r8), parameter :: a003 = -3.65270065530e-7_r8 -real (r8), parameter :: a004 = 3.14540999020e-7_r8 -real (r8), parameter :: a010 = 5.55242129680e-5_r8 -real (r8), parameter :: a011 = -2.34332137060e-5_r8 -real (r8), parameter :: a012 = 4.26100574800e-6_r8 -real (r8), parameter :: a013 = 5.73918103180e-7_r8 -real (r8), parameter :: a020 = -4.95634777770e-5_r8 -real (r8), parameter :: a021 = 2.37838968519e-5_r8 -real (r8), parameter :: a022 = -1.38397620111e-6_r8 -real (r8), parameter :: a030 = 2.76445290808e-5_r8 -real (r8), parameter :: a031 = -1.36408749928e-5_r8 -real (r8), parameter :: a032 = -2.53411666056e-7_r8 -real (r8), parameter :: a040 = -4.02698077700e-6_r8 -real (r8), parameter :: a041 = 2.53683834070e-6_r8 -real (r8), parameter :: a050 = 1.23258565608e-6_r8 -real (r8), parameter :: a100 = 3.50095997640e-5_r8 -real (r8), parameter :: a101 = -9.56770881560e-6_r8 -real (r8), parameter :: a102 = -5.56991545570e-6_r8 -real (r8), parameter :: a103 = -2.72956962370e-7_r8 -real (r8), parameter :: a110 = -7.48716846880e-5_r8 -real (r8), parameter :: a111 = -4.73566167220e-7_r8 -real (r8), parameter :: a112 = 7.82747741600e-7_r8 -real (r8), parameter :: a120 = 7.24244384490e-5_r8 -real (r8), parameter :: a121 = -1.03676320965e-5_r8 -real (r8), parameter :: a122 = 2.32856664276e-8_r8 -real (r8), parameter :: a130 = -3.50383492616e-5_r8 -real (r8), parameter :: a131 = 5.18268711320e-6_r8 -real (r8), parameter :: a140 = -1.65263794500e-6_r8 -real (r8), parameter :: a200 = -4.35926785610e-5_r8 -real (r8), parameter :: a201 = 1.11008347650e-5_r8 -real (r8), parameter :: a202 = 5.46207488340e-6_r8 -real (r8), parameter :: a210 = 7.18156455200e-5_r8 -real (r8), parameter :: a211 = 5.85666925900e-6_r8 -real (r8), parameter :: a212 = -1.31462208134e-6_r8 -real (r8), parameter :: a220 = -4.30608991440e-5_r8 -real (r8), parameter :: a221 = 9.49659182340e-7_r8 -real (r8), parameter :: a230 = 1.74814722392e-5_r8 -real (r8), parameter :: a300 = 3.45324618280e-5_r8 -real (r8), parameter :: a301 = -9.84471178440e-6_r8 -real (r8), parameter :: a302 = -1.35441856270e-6_r8 -real (r8), parameter :: a310 = -3.73971683740e-5_r8 -real (r8), parameter :: a311 = -9.76522784000e-7_r8 -real (r8), parameter :: a320 = 6.85899736680e-6_r8 -real (r8), parameter :: a400 = -1.19594097880e-5_r8 -real (r8), parameter :: a401 = 2.59092252600e-6_r8 -real (r8), parameter :: a410 = 7.71906784880e-6_r8 -real (r8), parameter :: a500 = 1.38645945810e-6_r8 - -real (r8), parameter :: b000 = -3.10389819760e-4_r8 -real (r8), parameter :: b003 = 3.63101885150e-7_r8 -real (r8), parameter :: b004 = -1.11471254230e-7_r8 -real (r8), parameter :: b010 = 3.50095997640e-5_r8 -real (r8), parameter :: b013 = -2.72956962370e-7_r8 -real (r8), parameter :: b020 = -3.74358423440e-5_r8 -real (r8), parameter :: b030 = 2.41414794830e-5_r8 -real (r8), parameter :: b040 = -8.75958731540e-6_r8 -real (r8), parameter :: b050 = -3.30527589000e-7_r8 -real (r8), parameter :: b100 = 1.33856134076e-3_r8 -real (r8), parameter :: b103 = 3.34926075600e-8_r8 -real (r8), parameter :: b110 = -8.71853571220e-5_r8 -real (r8), parameter :: b120 = 7.18156455200e-5_r8 -real (r8), parameter :: b130 = -2.87072660960e-5_r8 -real (r8), parameter :: b140 = 8.74073611960e-6_r8 -real (r8), parameter :: b200 = -2.55143801811e-3_r8 -real (r8), parameter :: b210 = 1.03597385484e-4_r8 -real (r8), parameter :: b220 = -5.60957525610e-5_r8 -real (r8), parameter :: b230 = 6.85899736680e-6_r8 -real (r8), parameter :: b300 = 2.32344279772e-3_r8 -real (r8), parameter :: b310 = -4.78376391520e-5_r8 -real (r8), parameter :: b320 = 1.54381356976e-5_r8 -real (r8), parameter :: b400 = -1.05461852535e-3_r8 -real (r8), parameter :: b410 = 6.93229729050e-6_r8 -real (r8), parameter :: b500 = 1.91594743830e-4_r8 -real (r8), parameter :: b001 = 2.42624687470e-5_r8 -real (r8), parameter :: b011 = -9.56770881560e-6_r8 -real (r8), parameter :: b021 = -2.36783083610e-7_r8 -real (r8), parameter :: b031 = -3.45587736550e-6_r8 -real (r8), parameter :: b041 = 1.29567177830e-6_r8 -real (r8), parameter :: b101 = -6.95849219480e-5_r8 -real (r8), parameter :: b111 = 2.22016695300e-5_r8 -real (r8), parameter :: b121 = 5.85666925900e-6_r8 -real (r8), parameter :: b131 = 6.33106121560e-7_r8 -real (r8), parameter :: b201 = 1.12412331915e-4_r8 -real (r8), parameter :: b211 = -2.95341353532e-5_r8 -real (r8), parameter :: b221 = -1.46478417600e-6_r8 -real (r8), parameter :: b301 = -6.92888744480e-5_r8 -real (r8), parameter :: b311 = 1.03636901040e-5_r8 -real (r8), parameter :: b401 = 1.54637136265e-5_r8 -real (r8), parameter :: b002 = -5.84844329840e-7_r8 -real (r8), parameter :: b012 = -5.56991545570e-6_r8 -real (r8), parameter :: b022 = 3.91373870800e-7_r8 -real (r8), parameter :: b032 = 7.76188880920e-9_r8 -real (r8), parameter :: b102 = -9.62445031940e-6_r8 -real (r8), parameter :: b112 = 1.09241497668e-5_r8 -real (r8), parameter :: b122 = -1.31462208134e-6_r8 -real (r8), parameter :: b202 = 1.47789320994e-5_r8 -real (r8), parameter :: b212 = -4.06325568810e-6_r8 -real (r8), parameter :: b302 = -7.12478989080e-6_r8 - -real (r8), parameter :: c000 = -6.07991438090e-5_r8 -real (r8), parameter :: c001 = 1.99712338438e-5_r8 -real (r8), parameter :: c002 = -3.39280843110e-6_r8 -real (r8), parameter :: c003 = 4.21246123200e-7_r8 -real (r8), parameter :: c004 = -6.32363064300e-8_r8 -real (r8), parameter :: c005 = 1.17681023580e-8_r8 -real (r8), parameter :: c010 = 1.85057654290e-5_r8 -real (r8), parameter :: c011 = -2.34727734620e-6_r8 -real (r8), parameter :: c012 = -1.09581019659e-6_r8 -real (r8), parameter :: c013 = 1.25816399608e-6_r8 -real (r8), parameter :: c020 = -1.17166068530e-5_r8 -real (r8), parameter :: c021 = 4.26100574800e-6_r8 -real (r8), parameter :: c022 = 8.60877154770e-7_r8 -real (r8), parameter :: c030 = 7.92796561730e-6_r8 -real (r8), parameter :: c031 = -9.22650800740e-7_r8 -real (r8), parameter :: c040 = -3.41021874820e-6_r8 -real (r8), parameter :: c041 = -1.26705833028e-7_r8 -real (r8), parameter :: c050 = 5.07367668140e-7_r8 -real (r8), parameter :: c100 = 2.42624687470e-5_r8 -real (r8), parameter :: c101 = -1.16968865968e-6_r8 -real (r8), parameter :: c102 = 1.08930565545e-6_r8 -real (r8), parameter :: c103 = -4.45885016920e-7_r8 -real (r8), parameter :: c110 = -9.56770881560e-6_r8 -real (r8), parameter :: c111 = -1.11398309114e-5_r8 -real (r8), parameter :: c112 = -8.18870887110e-7_r8 -real (r8), parameter :: c120 = -2.36783083610e-7_r8 -real (r8), parameter :: c121 = 7.82747741600e-7_r8 -real (r8), parameter :: c130 = -3.45587736550e-6_r8 -real (r8), parameter :: c131 = 1.55237776184e-8_r8 -real (r8), parameter :: c140 = 1.29567177830e-6_r8 -real (r8), parameter :: c200 = -3.47924609740e-5_r8 -real (r8), parameter :: c201 = -9.62445031940e-6_r8 -real (r8), parameter :: c202 = 5.02389113400e-8_r8 -real (r8), parameter :: c210 = 1.11008347650e-5_r8 -real (r8), parameter :: c211 = 1.09241497668e-5_r8 -real (r8), parameter :: c220 = 2.92833462950e-6_r8 -real (r8), parameter :: c221 = -1.31462208134e-6_r8 -real (r8), parameter :: c230 = 3.16553060780e-7_r8 -real (r8), parameter :: c300 = 3.74707773050e-5_r8 -real (r8), parameter :: c301 = 9.85262139960e-6_r8 -real (r8), parameter :: c310 = -9.84471178440e-6_r8 -real (r8), parameter :: c311 = -2.70883712540e-6_r8 -real (r8), parameter :: c320 = -4.88261392000e-7_r8 -real (r8), parameter :: c400 = -1.73222186120e-5_r8 -real (r8), parameter :: c401 = -3.56239494540e-6_r8 -real (r8), parameter :: c410 = 2.59092252600e-6_r8 -real (r8), parameter :: c500 = 3.09274272530e-6_r8 - -real (r8), parameter :: h001 = 1.07699958620e-3_r8 -real (r8), parameter :: h002 = -3.03995719050e-5_r8 -real (r8), parameter :: h003 = 3.32853897400e-6_r8 -real (r8), parameter :: h004 = -2.82734035930e-7_r8 -real (r8), parameter :: h005 = 2.10623061600e-8_r8 -real (r8), parameter :: h006 = -2.10787688100e-9_r8 -real (r8), parameter :: h007 = 2.80192913290e-10_r8 -real (r8), parameter :: h011 = -1.56497346750e-5_r8 -real (r8), parameter :: h012 = 9.25288271450e-6_r8 -real (r8), parameter :: h013 = -3.91212891030e-7_r8 -real (r8), parameter :: h014 = -9.13175163830e-8_r8 -real (r8), parameter :: h015 = 6.29081998040e-8_r8 -real (r8), parameter :: h021 = 2.77621064840e-5_r8 -real (r8), parameter :: h022 = -5.85830342650e-6_r8 -real (r8), parameter :: h023 = 7.10167624670e-7_r8 -real (r8), parameter :: h024 = 7.17397628980e-8_r8 -real (r8), parameter :: h031 = -1.65211592590e-5_r8 -real (r8), parameter :: h032 = 3.96398280870e-6_r8 -real (r8), parameter :: h033 = -1.53775133460e-7_r8 -real (r8), parameter :: h042 = -1.70510937410e-6_r8 -real (r8), parameter :: h043 = -2.11176388380e-8_r8 -real (r8), parameter :: h041 = 6.91113227020e-6_r8 -real (r8), parameter :: h051 = -8.05396155400e-7_r8 -real (r8), parameter :: h052 = 2.53683834070e-7_r8 -real (r8), parameter :: h061 = 2.05430942680e-7_r8 -real (r8), parameter :: h101 = -3.10389819760e-4_r8 -real (r8), parameter :: h102 = 1.21312343735e-5_r8 -real (r8), parameter :: h103 = -1.94948109950e-7_r8 -real (r8), parameter :: h104 = 9.07754712880e-8_r8 -real (r8), parameter :: h105 = -2.22942508460e-8_r8 -real (r8), parameter :: h111 = 3.50095997640e-5_r8 -real (r8), parameter :: h112 = -4.78385440780e-6_r8 -real (r8), parameter :: h113 = -1.85663848520e-6_r8 -real (r8), parameter :: h114 = -6.82392405930e-8_r8 -real (r8), parameter :: h121 = -3.74358423440e-5_r8 -real (r8), parameter :: h122 = -1.18391541805e-7_r8 -real (r8), parameter :: h123 = 1.30457956930e-7_r8 -real (r8), parameter :: h131 = 2.41414794830e-5_r8 -real (r8), parameter :: h132 = -1.72793868275e-6_r8 -real (r8), parameter :: h133 = 2.58729626970e-9_r8 -real (r8), parameter :: h141 = -8.75958731540e-6_r8 -real (r8), parameter :: h142 = 6.47835889150e-7_r8 -real (r8), parameter :: h151 = -3.30527589000e-7_r8 -real (r8), parameter :: h201 = 6.69280670380e-4_r8 -real (r8), parameter :: h202 = -1.73962304870e-5_r8 -real (r8), parameter :: h203 = -1.60407505320e-6_r8 -real (r8), parameter :: h204 = 4.18657594500e-9_r8 -real (r8), parameter :: h211 = -4.35926785610e-5_r8 -real (r8), parameter :: h212 = 5.55041738250e-6_r8 -real (r8), parameter :: h213 = 1.82069162780e-6_r8 -real (r8), parameter :: h221 = 3.59078227600e-5_r8 -real (r8), parameter :: h222 = 1.46416731475e-6_r8 -real (r8), parameter :: h223 = -2.19103680220e-7_r8 -real (r8), parameter :: h231 = -1.43536330480e-5_r8 -real (r8), parameter :: h232 = 1.58276530390e-7_r8 -real (r8), parameter :: h241 = 4.37036805980e-6_r8 -real (r8), parameter :: h301 = -8.50479339370e-4_r8 -real (r8), parameter :: h302 = 1.87353886525e-5_r8 -real (r8), parameter :: h303 = 1.64210356660e-6_r8 -real (r8), parameter :: h311 = 3.45324618280e-5_r8 -real (r8), parameter :: h312 = -4.92235589220e-6_r8 -real (r8), parameter :: h313 = -4.51472854230e-7_r8 -real (r8), parameter :: h321 = -1.86985841870e-5_r8 -real (r8), parameter :: h322 = -2.44130696000e-7_r8 -real (r8), parameter :: h331 = 2.28633245560e-6_r8 -real (r8), parameter :: h401 = 5.80860699430e-4_r8 -real (r8), parameter :: h402 = -8.66110930600e-6_r8 -real (r8), parameter :: h403 = -5.93732490900e-7_r8 -real (r8), parameter :: h411 = -1.19594097880e-5_r8 -real (r8), parameter :: h421 = 3.85953392440e-6_r8 -real (r8), parameter :: h412 = 1.29546126300e-6_r8 -real (r8), parameter :: h501 = -2.10923705070e-4_r8 -real (r8), parameter :: h502 = 1.54637136265e-6_r8 -real (r8), parameter :: h511 = 1.38645945810e-6_r8 -real (r8), parameter :: h601 = 3.19324573050e-5_r8 - -real (r8), parameter :: v000 = 1.0769995862e-3_r8 -real (r8), parameter :: v001 = -6.0799143809e-5_r8 -real (r8), parameter :: v002 = 9.9856169219e-6_r8 -real (r8), parameter :: v003 = -1.1309361437e-6_r8 -real (r8), parameter :: v004 = 1.0531153080e-7_r8 -real (r8), parameter :: v005 = -1.2647261286e-8_r8 -real (r8), parameter :: v006 = 1.9613503930e-9_r8 -real (r8), parameter :: v010 = -3.1038981976e-4_r8 -real (r8), parameter :: v011 = 2.4262468747e-5_r8 -real (r8), parameter :: v012 = -5.8484432984e-7_r8 -real (r8), parameter :: v013 = 3.6310188515e-7_r8 -real (r8), parameter :: v014 = -1.1147125423e-7_r8 -real (r8), parameter :: v020 = 6.6928067038e-4_r8 -real (r8), parameter :: v021 = -3.4792460974e-5_r8 -real (r8), parameter :: v022 = -4.8122251597e-6_r8 -real (r8), parameter :: v023 = 1.6746303780e-8_r8 -real (r8), parameter :: v030 = -8.5047933937e-4_r8 -real (r8), parameter :: v031 = 3.7470777305e-5_r8 -real (r8), parameter :: v032 = 4.9263106998e-6_r8 -real (r8), parameter :: v040 = 5.8086069943e-4_r8 -real (r8), parameter :: v041 = -1.7322218612e-5_r8 -real (r8), parameter :: v042 = -1.7811974727e-6_r8 -real (r8), parameter :: v050 = -2.1092370507e-4_r8 -real (r8), parameter :: v051 = 3.0927427253e-6_r8 -real (r8), parameter :: v060 = 3.1932457305e-5_r8 -real (r8), parameter :: v100 = -1.5649734675e-5_r8 -real (r8), parameter :: v101 = 1.8505765429e-5_r8 -real (r8), parameter :: v102 = -1.1736386731e-6_r8 -real (r8), parameter :: v103 = -3.6527006553e-7_r8 -real (r8), parameter :: v104 = 3.1454099902e-7_r8 -real (r8), parameter :: v110 = 3.5009599764e-5_r8 -real (r8), parameter :: v111 = -9.5677088156e-6_r8 -real (r8), parameter :: v112 = -5.5699154557e-6_r8 -real (r8), parameter :: v113 = -2.7295696237e-7_r8 -real (r8), parameter :: v120 = -4.3592678561e-5_r8 -real (r8), parameter :: v121 = 1.1100834765e-5_r8 -real (r8), parameter :: v122 = 5.4620748834e-6_r8 -real (r8), parameter :: v130 = 3.4532461828e-5_r8 -real (r8), parameter :: v131 = -9.8447117844e-6_r8 -real (r8), parameter :: v132 = -1.3544185627e-6_r8 -real (r8), parameter :: v140 = -1.1959409788e-5_r8 -real (r8), parameter :: v141 = 2.5909225260e-6_r8 -real (r8), parameter :: v150 = 1.3864594581e-6_r8 -real (r8), parameter :: v200 = 2.7762106484e-5_r8 -real (r8), parameter :: v201 = -1.1716606853e-5_r8 -real (r8), parameter :: v202 = 2.1305028740e-6_r8 -real (r8), parameter :: v203 = 2.8695905159e-7_r8 -real (r8), parameter :: v210 = -3.7435842344e-5_r8 -real (r8), parameter :: v211 = -2.3678308361e-7_r8 -real (r8), parameter :: v212 = 3.9137387080e-7_r8 -real (r8), parameter :: v220 = 3.5907822760e-5_r8 -real (r8), parameter :: v221 = 2.9283346295e-6_r8 -real (r8), parameter :: v222 = -6.5731104067e-7_r8 -real (r8), parameter :: v230 = -1.8698584187e-5_r8 -real (r8), parameter :: v231 = -4.8826139200e-7_r8 -real (r8), parameter :: v240 = 3.8595339244e-6_r8 -real (r8), parameter :: v300 = -1.6521159259e-5_r8 -real (r8), parameter :: v301 = 7.9279656173e-6_r8 -real (r8), parameter :: v302 = -4.6132540037e-7_r8 -real (r8), parameter :: v310 = 2.4141479483e-5_r8 -real (r8), parameter :: v311 = -3.4558773655e-6_r8 -real (r8), parameter :: v312 = 7.7618888092e-9_r8 -real (r8), parameter :: v320 = -1.4353633048e-5_r8 -real (r8), parameter :: v321 = 3.1655306078e-7_r8 -real (r8), parameter :: v330 = 2.2863324556e-6_r8 -real (r8), parameter :: v400 = 6.9111322702e-6_r8 -real (r8), parameter :: v401 = -3.4102187482e-6_r8 -real (r8), parameter :: v402 = -6.3352916514e-8_r8 -real (r8), parameter :: v410 = -8.7595873154e-6_r8 -real (r8), parameter :: v411 = 1.2956717783e-6_r8 -real (r8), parameter :: v420 = 4.3703680598e-6_r8 -real (r8), parameter :: v500 = -8.0539615540e-7_r8 -real (r8), parameter :: v501 = 5.0736766814e-7_r8 -real (r8), parameter :: v510 = -3.3052758900e-7_r8 -real (r8), parameter :: v600 = 2.0543094268e-7_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 new file mode 120000 index 0000000000..934f689c20 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_specvol_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 deleted file mode 100644 index e3c6afbce0..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 +++ /dev/null @@ -1,71 +0,0 @@ -!========================================================================== -module gsw_mod_teos10_constants -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: db2pa = 1.0e4_r8 -real (r8), parameter :: rec_db2pa = 1.0e-4_r8 - -real (r8), parameter :: pa2db = 1.0e-4_r8 -real (r8), parameter :: rec_pa2db = 1.0e4_r8 - -real (r8), parameter :: pi = 3.141592653589793_r8 -real (r8), parameter :: deg2rad = pi/180.0_r8 -real (r8), parameter :: rad2deg = 180.0_r8/pi - -real (r8), parameter :: gamma = 2.26e-7_r8 - -! cp0 = The "specific heat" for use [ J/(kg K) ] -! with Conservative Temperature - -real (r8), parameter :: gsw_cp0 = 3991.86795711963_r8 - -! T0 = the Celcius zero point. [ K ] - -real (r8), parameter :: gsw_t0 = 273.15_r8 - -! P0 = Absolute Pressure of one standard atmosphere. [ Pa ] - -real (r8), parameter :: gsw_p0 = 101325.0_r8 - -! SSO = Standard Ocean Reference Salinity. [ g/kg ] - -real (r8), parameter :: gsw_sso = 35.16504_r8 -real (r8), parameter :: gsw_sqrtsso = 5.930011804372737_r8 - -! uPS = unit conversion factor for salinities [ g/kg ] - -real (r8), parameter :: gsw_ups = gsw_sso/35.0_r8 - -! sfac = 1/(40*gsw_ups) - -real (r8), parameter :: gsw_sfac = 0.0248826675584615_r8 - -! deltaS = 24, offset = deltaS*gsw_sfac - -real (r8), parameter :: offset = 5.971840214030754e-1_r8 - -! C3515 = Conductivity at (SP=35, t_68=15, p=0) [ mS/cm ] - -real (r8), parameter :: gsw_c3515 = 42.9140_r8 - -! SonCl = SP to Chlorinity ratio [ (g/kg)^-1 ] - -real (r8), parameter :: gsw_soncl = 1.80655_r8 - -! valence_factor = valence factor of sea salt of Reference Composition -! [ unitless ] - -real (r8), parameter :: gsw_valence_factor = 1.2452898_r8 - -! atomic_weight = mole-weighted atomic weight of sea salt of Reference -! Composition [ g/mol ] - -real (r8), parameter :: gsw_atomic_weight = 31.4038218_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 new file mode 120000 index 0000000000..17dec5add5 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_teos10_constants.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 deleted file mode 100644 index a8012e1274..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 +++ /dev/null @@ -1,1493 +0,0 @@ -module gsw_mod_toolbox - -use gsw_mod_kinds - -implicit none - -public :: gsw_add_barrier -public :: gsw_add_mean -public :: gsw_adiabatic_lapse_rate_from_ct -public :: gsw_adiabatic_lapse_rate_ice -public :: gsw_alpha -public :: gsw_alpha_on_beta -public :: gsw_alpha_wrt_t_exact -public :: gsw_alpha_wrt_t_ice -public :: gsw_beta_const_t_exact -public :: gsw_beta -public :: gsw_cabbeling -public :: gsw_c_from_sp -public :: gsw_chem_potential_water_ice -public :: gsw_chem_potential_water_t_exact -public :: gsw_cp_ice -public :: gsw_ct_first_derivatives -public :: gsw_ct_first_derivatives_wrt_t_exact -public :: gsw_ct_freezing_exact -public :: gsw_ct_freezing -public :: gsw_ct_freezing_first_derivatives -public :: gsw_ct_freezing_first_derivatives_poly -public :: gsw_ct_freezing_poly -public :: gsw_ct_from_enthalpy_exact -public :: gsw_ct_from_enthalpy -public :: gsw_ct_from_entropy -public :: gsw_ct_from_pt -public :: gsw_ct_from_rho -public :: gsw_ct_from_t -public :: gsw_ct_maxdensity -public :: gsw_ct_second_derivatives -public :: gsw_deltasa_atlas -public :: gsw_deltasa_from_sp -public :: gsw_dilution_coefficient_t_exact -public :: gsw_dynamic_enthalpy -public :: gsw_enthalpy_ct_exact -public :: gsw_enthalpy_diff -public :: gsw_enthalpy -public :: gsw_enthalpy_first_derivatives_ct_exact -public :: gsw_enthalpy_first_derivatives -public :: gsw_enthalpy_ice -public :: gsw_enthalpy_second_derivatives_ct_exact -public :: gsw_enthalpy_second_derivatives -public :: gsw_enthalpy_sso_0 -public :: gsw_enthalpy_t_exact -public :: gsw_entropy_first_derivatives -public :: gsw_entropy_from_pt -public :: gsw_entropy_from_t -public :: gsw_entropy_ice -public :: gsw_entropy_part -public :: gsw_entropy_part_zerop -public :: gsw_entropy_second_derivatives -public :: gsw_fdelta -public :: gsw_frazil_properties -public :: gsw_frazil_properties_potential -public :: gsw_frazil_properties_potential_poly -public :: gsw_frazil_ratios_adiabatic -public :: gsw_frazil_ratios_adiabatic_poly -public :: gsw_geo_strf_dyn_height -public :: gsw_geo_strf_dyn_height_pc -public :: gsw_gibbs -public :: gsw_gibbs_ice -public :: gsw_gibbs_ice_part_t -public :: gsw_gibbs_ice_pt0 -public :: gsw_gibbs_ice_pt0_pt0 -public :: gsw_gibbs_pt0_pt0 -public :: gsw_grav -public :: gsw_helmholtz_energy_ice -public :: gsw_hill_ratio_at_sp2 -public :: gsw_ice_fraction_to_freeze_seawater -public :: gsw_internal_energy -public :: gsw_internal_energy_ice -public :: gsw_ipv_vs_fnsquared_ratio -public :: gsw_kappa_const_t_ice -public :: gsw_kappa -public :: gsw_kappa_ice -public :: gsw_kappa_t_exact -public :: gsw_latentheat_evap_ct -public :: gsw_latentheat_evap_t -public :: gsw_latentheat_melting -public :: gsw_linear_interp_sa_ct -public :: gsw_melting_ice_equilibrium_sa_ct_ratio -public :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly -public :: gsw_melting_ice_into_seawater -public :: gsw_melting_ice_sa_ct_ratio -public :: gsw_melting_ice_sa_ct_ratio_poly -public :: gsw_melting_seaice_equilibrium_sa_ct_ratio -public :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly -public :: gsw_melting_seaice_into_seawater -public :: gsw_melting_seaice_sa_ct_ratio -public :: gsw_melting_seaice_sa_ct_ratio_poly -public :: gsw_nsquared -public :: gsw_pot_enthalpy_from_pt_ice -public :: gsw_pot_enthalpy_from_pt_ice_poly -public :: gsw_pot_enthalpy_ice_freezing -public :: gsw_pot_enthalpy_ice_freezing_first_derivatives -public :: gsw_pot_enthalpy_ice_freezing_first_derivatives_poly -public :: gsw_pot_enthalpy_ice_freezing_poly -public :: gsw_pot_rho_t_exact -public :: gsw_pressure_coefficient_ice -public :: gsw_pressure_freezing_ct -public :: gsw_pt0_cold_ice_poly -public :: gsw_pt0_from_t -public :: gsw_pt0_from_t_ice -public :: gsw_pt_first_derivatives -public :: gsw_pt_from_ct -public :: gsw_pt_from_entropy -public :: gsw_pt_from_pot_enthalpy_ice -public :: gsw_pt_from_pot_enthalpy_ice_poly_dh -public :: gsw_pt_from_pot_enthalpy_ice_poly -public :: gsw_pt_from_t -public :: gsw_pt_from_t_ice -public :: gsw_pt_second_derivatives -public :: gsw_rho_alpha_beta -public :: gsw_rho -public :: gsw_rho_first_derivatives -public :: gsw_rho_first_derivatives_wrt_enthalpy -public :: gsw_rho_ice -public :: gsw_rho_second_derivatives -public :: gsw_rho_second_derivatives_wrt_enthalpy -public :: gsw_rho_t_exact -public :: gsw_rr68_interp_sa_ct -public :: gsw_saar -public :: gsw_sa_freezing_estimate -public :: gsw_sa_freezing_from_ct -public :: gsw_sa_freezing_from_ct_poly -public :: gsw_sa_freezing_from_t -public :: gsw_sa_freezing_from_t_poly -public :: gsw_sa_from_rho -public :: gsw_sa_from_sp_baltic -public :: gsw_sa_from_sp -public :: gsw_sa_from_sstar -public :: gsw_sa_p_inrange -public :: gsw_seaice_fraction_to_freeze_seawater -public :: gsw_sigma0 -public :: gsw_sigma1 -public :: gsw_sigma2 -public :: gsw_sigma3 -public :: gsw_sigma4 -public :: gsw_sound_speed -public :: gsw_sound_speed_ice -public :: gsw_sound_speed_t_exact -public :: gsw_specvol_alpha_beta -public :: gsw_specvol_anom_standard -public :: gsw_specvol -public :: gsw_specvol_first_derivatives -public :: gsw_specvol_first_derivatives_wrt_enthalpy -public :: gsw_specvol_ice -public :: gsw_specvol_second_derivatives -public :: gsw_specvol_second_derivatives_wrt_enthalpy -public :: gsw_specvol_sso_0 -public :: gsw_specvol_t_exact -public :: gsw_sp_from_c -public :: gsw_sp_from_sa_baltic -public :: gsw_sp_from_sa -public :: gsw_sp_from_sk -public :: gsw_sp_from_sr -public :: gsw_sp_from_sstar -public :: gsw_spiciness0 -public :: gsw_spiciness1 -public :: gsw_spiciness2 -public :: gsw_sr_from_sp -public :: gsw_sstar_from_sa -public :: gsw_sstar_from_sp -public :: gsw_t_deriv_chem_potential_water_t_exact -public :: gsw_t_freezing_exact -public :: gsw_t_freezing -public :: gsw_t_freezing_first_derivatives -public :: gsw_t_freezing_first_derivatives_poly -public :: gsw_t_freezing_poly -public :: gsw_t_from_ct -public :: gsw_t_from_pt0_ice -public :: gsw_thermobaric -public :: gsw_turner_rsubrho -public :: gsw_util_indx -public :: gsw_util_interp1q_int -public :: gsw_util_sort_real -public :: gsw_util_xinterp1 -public :: gsw_z_from_p - -interface - - pure subroutine gsw_add_barrier (input_data, long, lat, long_grid, & - lat_grid, dlong_grid, dlat_grid, output_data) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: long, lat, long_grid, lat_grid, dlong_grid - real (r8), intent(in) :: dlat_grid - real (r8), intent(in), dimension(4) :: input_data - real (r8), intent(out), dimension(4) :: output_data - end subroutine gsw_add_barrier - - pure subroutine gsw_add_mean (data_in, data_out) - use gsw_mod_kinds - implicit none - real (r8), intent(in), dimension(4) :: data_in - real (r8), intent(out), dimension(4) :: data_out - end subroutine gsw_add_mean - - elemental function gsw_adiabatic_lapse_rate_from_ct (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_adiabatic_lapse_rate_from_ct - end function gsw_adiabatic_lapse_rate_from_ct - - elemental function gsw_adiabatic_lapse_rate_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_adiabatic_lapse_rate_ice - end function gsw_adiabatic_lapse_rate_ice - - elemental function gsw_alpha (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_alpha - end function gsw_alpha - - elemental function gsw_alpha_on_beta (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_alpha_on_beta - end function gsw_alpha_on_beta - - elemental function gsw_alpha_wrt_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_alpha_wrt_t_exact - end function gsw_alpha_wrt_t_exact - - elemental function gsw_alpha_wrt_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_alpha_wrt_t_ice - end function gsw_alpha_wrt_t_ice - - elemental function gsw_beta_const_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_beta_const_t_exact - end function gsw_beta_const_t_exact - - elemental function gsw_beta (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_beta - end function gsw_beta - - elemental function gsw_cabbeling (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_cabbeling - end function gsw_cabbeling - - elemental function gsw_c_from_sp (sp, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, t, p - real (r8) :: gsw_c_from_sp - end function gsw_c_from_sp - - elemental function gsw_chem_potential_water_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_chem_potential_water_ice - end function gsw_chem_potential_water_ice - - elemental function gsw_chem_potential_water_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_chem_potential_water_t_exact - end function gsw_chem_potential_water_t_exact - - elemental function gsw_cp_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_cp_ice - end function gsw_cp_ice - - elemental subroutine gsw_ct_first_derivatives (sa, pt, ct_sa, ct_pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8), intent(out), optional :: ct_sa, ct_pt - end subroutine gsw_ct_first_derivatives - - elemental subroutine gsw_ct_first_derivatives_wrt_t_exact (sa, t, p, & - ct_sa_wrt_t, ct_t_wrt_t, ct_p_wrt_t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8), intent(out), optional :: ct_p_wrt_t, ct_sa_wrt_t, ct_t_wrt_t - end subroutine gsw_ct_first_derivatives_wrt_t_exact - - elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_ct_freezing_exact - end function gsw_ct_freezing_exact - - elemental function gsw_ct_freezing (sa, p, saturation_fraction, poly) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - logical, intent(in), optional :: poly - real (r8) :: gsw_ct_freezing - end function gsw_ct_freezing - - elemental subroutine gsw_ct_freezing_first_derivatives (sa, p, & - saturation_fraction, ctfreezing_sa, ctfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p - end subroutine gsw_ct_freezing_first_derivatives - - elemental subroutine gsw_ct_freezing_first_derivatives_poly (sa, p, & - saturation_fraction, ctfreezing_sa, ctfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p - end subroutine gsw_ct_freezing_first_derivatives_poly - - elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_ct_freezing_poly - end function gsw_ct_freezing_poly - - elemental function gsw_ct_from_enthalpy_exact (sa, h, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, h, p - real (r8) :: gsw_ct_from_enthalpy_exact - end function gsw_ct_from_enthalpy_exact - - elemental function gsw_ct_from_enthalpy (sa, h, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, h, p - real (r8) :: gsw_ct_from_enthalpy - end function gsw_ct_from_enthalpy - - elemental function gsw_ct_from_entropy (sa, entropy) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, entropy - real (r8) :: gsw_ct_from_entropy - end function gsw_ct_from_entropy - - elemental function gsw_ct_from_pt (sa, pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8) :: gsw_ct_from_pt - end function gsw_ct_from_pt - - elemental subroutine gsw_ct_from_rho (rho, sa, p, ct, ct_multiple) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rho, sa, p - real (r8), intent(out) :: ct - real (r8), intent(out), optional :: ct_multiple - end subroutine gsw_ct_from_rho - - elemental function gsw_ct_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_ct_from_t - end function gsw_ct_from_t - - elemental function gsw_ct_maxdensity (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_ct_maxdensity - end function gsw_ct_maxdensity - - elemental subroutine gsw_ct_second_derivatives (sa, pt, ct_sa_sa, ct_sa_pt, & - ct_pt_pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8), intent(out), optional :: ct_sa_sa, ct_sa_pt, ct_pt_pt - end subroutine gsw_ct_second_derivatives - - elemental function gsw_deltasa_atlas (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_deltasa_atlas - end function gsw_deltasa_atlas - - elemental function gsw_deltasa_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_deltasa_from_sp - end function gsw_deltasa_from_sp - - elemental function gsw_dilution_coefficient_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_dilution_coefficient_t_exact - end function gsw_dilution_coefficient_t_exact - - elemental function gsw_dynamic_enthalpy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_dynamic_enthalpy - end function gsw_dynamic_enthalpy - - elemental function gsw_enthalpy_ct_exact (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_enthalpy_ct_exact - end function gsw_enthalpy_ct_exact - - elemental function gsw_enthalpy_diff (sa, ct, p_shallow, p_deep) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p_shallow, p_deep - real (r8) :: gsw_enthalpy_diff - end function gsw_enthalpy_diff - - elemental function gsw_enthalpy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_enthalpy - end function gsw_enthalpy - - elemental subroutine gsw_enthalpy_first_derivatives_ct_exact (sa, ct, p, & - h_sa, h_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa, h_ct - end subroutine gsw_enthalpy_first_derivatives_ct_exact - - elemental subroutine gsw_enthalpy_first_derivatives (sa, ct, p, h_sa, h_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa, h_ct - end subroutine gsw_enthalpy_first_derivatives - - elemental function gsw_enthalpy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_enthalpy_ice - end function gsw_enthalpy_ice - - elemental subroutine gsw_enthalpy_second_derivatives_ct_exact (sa, ct, p, & - h_sa_sa, h_sa_ct, h_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct - end subroutine gsw_enthalpy_second_derivatives_ct_exact - - elemental subroutine gsw_enthalpy_second_derivatives (sa, ct, p, h_sa_sa, & - h_sa_ct, h_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct - end subroutine gsw_enthalpy_second_derivatives - - elemental function gsw_enthalpy_sso_0 (p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p - real (r8) :: gsw_enthalpy_sso_0 - end function gsw_enthalpy_sso_0 - - elemental function gsw_enthalpy_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_enthalpy_t_exact - end function gsw_enthalpy_t_exact - - elemental subroutine gsw_entropy_first_derivatives (sa, ct, eta_sa, eta_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: eta_sa, eta_ct - end subroutine gsw_entropy_first_derivatives - - elemental function gsw_entropy_from_pt (sa, pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8) :: gsw_entropy_from_pt - end function gsw_entropy_from_pt - - elemental function gsw_entropy_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_entropy_from_t - end function gsw_entropy_from_t - - elemental function gsw_entropy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_entropy_ice - end function gsw_entropy_ice - - elemental function gsw_entropy_part (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_entropy_part - end function gsw_entropy_part - - elemental function gsw_entropy_part_zerop (sa, pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt0 - real (r8) :: gsw_entropy_part_zerop - end function gsw_entropy_part_zerop - - elemental subroutine gsw_entropy_second_derivatives (sa, ct, eta_sa_sa, & - eta_sa_ct, eta_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: eta_sa_sa, eta_sa_ct, eta_ct_ct - end subroutine gsw_entropy_second_derivatives - - elemental function gsw_fdelta (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_fdelta - end function gsw_fdelta - - elemental subroutine gsw_frazil_properties (sa_bulk, h_bulk, p, & - sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties - - elemental subroutine gsw_frazil_properties_potential (sa_bulk, h_pot_bulk,& - p, sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_pot_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties_potential - - elemental subroutine gsw_frazil_properties_potential_poly (sa_bulk, & - h_pot_bulk, p, sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_pot_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties_potential_poly - - elemental subroutine gsw_frazil_ratios_adiabatic (sa, p, w_ih, & - dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, w_ih - real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil - end subroutine gsw_frazil_ratios_adiabatic - - elemental subroutine gsw_frazil_ratios_adiabatic_poly (sa, p, w_ih, & - dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, w_ih - real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil - end subroutine gsw_frazil_ratios_adiabatic_poly - - pure function gsw_geo_strf_dyn_height (sa, ct, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref - real (r8) :: gsw_geo_strf_dyn_height(size(sa)) - end function gsw_geo_strf_dyn_height - - pure subroutine gsw_geo_strf_dyn_height_pc (sa, ct, delta_p, & - geo_strf_dyn_height_pc, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), delta_p(:) - real (r8), intent(out) :: geo_strf_dyn_height_pc(:), p_mid(:) - end subroutine gsw_geo_strf_dyn_height_pc - - elemental function gsw_gibbs (ns, nt, np, sa, t, p) - use gsw_mod_kinds - implicit none - integer, intent(in) :: ns, nt, np - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_gibbs - end function gsw_gibbs - - elemental function gsw_gibbs_ice (nt, np, t, p) - use gsw_mod_kinds - implicit none - integer, intent(in) :: nt, np - real (r8), intent(in) :: t, p - real (r8) :: gsw_gibbs_ice - end function gsw_gibbs_ice - - elemental function gsw_gibbs_ice_part_t (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_gibbs_ice_part_t - end function gsw_gibbs_ice_part_t - - elemental function gsw_gibbs_ice_pt0 (pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0 - real (r8) :: gsw_gibbs_ice_pt0 - end function gsw_gibbs_ice_pt0 - - elemental function gsw_gibbs_ice_pt0_pt0 (pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0 - real (r8) :: gsw_gibbs_ice_pt0_pt0 - end function gsw_gibbs_ice_pt0_pt0 - - elemental function gsw_gibbs_pt0_pt0 (sa, pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt0 - real (r8) :: gsw_gibbs_pt0_pt0 - end function gsw_gibbs_pt0_pt0 - - elemental function gsw_grav (lat, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: lat, p - real (r8) :: gsw_grav - end function gsw_grav - - elemental function gsw_helmholtz_energy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_helmholtz_energy_ice - end function gsw_helmholtz_energy_ice - - elemental function gsw_hill_ratio_at_sp2 (t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t - real (r8) :: gsw_hill_ratio_at_sp2 - end function gsw_hill_ratio_at_sp2 - - elemental subroutine gsw_ice_fraction_to_freeze_seawater (sa, ct, p, & - t_ih, sa_freeze, ct_freeze, w_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8), intent(out) :: sa_freeze, ct_freeze, w_ih - end subroutine gsw_ice_fraction_to_freeze_seawater - - elemental function gsw_internal_energy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_internal_energy - end function gsw_internal_energy - - elemental function gsw_internal_energy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_internal_energy_ice - end function gsw_internal_energy_ice - - pure subroutine gsw_ipv_vs_fnsquared_ratio (sa, ct, p, p_ref, & - ipv_vs_fnsquared_ratio, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref - real (r8), intent(out) :: ipv_vs_fnsquared_ratio(:), p_mid(:) - end subroutine gsw_ipv_vs_fnsquared_ratio - - elemental function gsw_kappa_const_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_kappa_const_t_ice - end function gsw_kappa_const_t_ice - - elemental function gsw_kappa (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_kappa - end function gsw_kappa - - elemental function gsw_kappa_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_kappa_ice - end function gsw_kappa_ice - - elemental function gsw_kappa_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_kappa_t_exact - end function gsw_kappa_t_exact - - elemental function gsw_latentheat_evap_ct (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_latentheat_evap_ct - end function gsw_latentheat_evap_ct - - elemental function gsw_latentheat_evap_t (sa, t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t - real (r8) :: gsw_latentheat_evap_t - end function gsw_latentheat_evap_t - - elemental function gsw_latentheat_melting (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_latentheat_melting - end function gsw_latentheat_melting - - pure subroutine gsw_linear_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) - real (r8), intent(out) :: sa_i(:), ct_i(:) - end subroutine gsw_linear_interp_sa_ct - - elemental function gsw_melting_ice_equilibrium_sa_ct_ratio (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio - end function gsw_melting_ice_equilibrium_sa_ct_ratio - - elemental function gsw_melting_ice_equilibrium_sa_ct_ratio_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly - end function gsw_melting_ice_equilibrium_sa_ct_ratio_poly - - elemental subroutine gsw_melting_ice_into_seawater (sa, ct, p, w_ih, t_ih,& - sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, w_ih, t_ih - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_melting_ice_into_seawater - - elemental function gsw_melting_ice_sa_ct_ratio (sa, ct, p, t_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8) :: gsw_melting_ice_sa_ct_ratio - end function gsw_melting_ice_sa_ct_ratio - - elemental function gsw_melting_ice_sa_ct_ratio_poly (sa, ct, p, t_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8) :: gsw_melting_ice_sa_ct_ratio_poly - end function gsw_melting_ice_sa_ct_ratio_poly - - elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio - end function gsw_melting_seaice_equilibrium_sa_ct_ratio - - elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly - end function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly - - elemental subroutine gsw_melting_seaice_into_seawater (sa, ct, p, & - w_seaice, sa_seaice, t_seaice, sa_final, ct_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, w_seaice, sa_seaice, t_seaice - real (r8), intent(out) :: sa_final, ct_final - end subroutine gsw_melting_seaice_into_seawater - - elemental function gsw_melting_seaice_sa_ct_ratio (sa, ct, p, sa_seaice, & - t_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8) :: gsw_melting_seaice_sa_ct_ratio - end function gsw_melting_seaice_sa_ct_ratio - - elemental function gsw_melting_seaice_sa_ct_ratio_poly (sa, ct, p, & - sa_seaice, t_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8) :: gsw_melting_seaice_sa_ct_ratio_poly - end function gsw_melting_seaice_sa_ct_ratio_poly - - pure subroutine gsw_nsquared (sa, ct, p, lat, n2, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), lat(:) - real (r8), intent(out) :: n2(:), p_mid(:) - end subroutine gsw_nsquared - - elemental function gsw_pot_enthalpy_from_pt_ice (pt0_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice - real (r8) :: gsw_pot_enthalpy_from_pt_ice - end function gsw_pot_enthalpy_from_pt_ice - - elemental function gsw_pot_enthalpy_from_pt_ice_poly (pt0_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice - real (r8) :: gsw_pot_enthalpy_from_pt_ice_poly - end function gsw_pot_enthalpy_from_pt_ice_poly - - elemental function gsw_pot_enthalpy_ice_freezing (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_pot_enthalpy_ice_freezing - end function gsw_pot_enthalpy_ice_freezing - - elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives (sa, & - p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p - end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives - - elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly(& - sa, p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p - end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly - - elemental function gsw_pot_enthalpy_ice_freezing_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_pot_enthalpy_ice_freezing_poly - end function gsw_pot_enthalpy_ice_freezing_poly - - elemental function gsw_pot_rho_t_exact (sa, t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p, p_ref - real (r8) :: gsw_pot_rho_t_exact - end function gsw_pot_rho_t_exact - - elemental function gsw_pressure_coefficient_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_pressure_coefficient_ice - end function gsw_pressure_coefficient_ice - - elemental function gsw_pressure_freezing_ct (sa, ct, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, saturation_fraction - real (r8) :: gsw_pressure_freezing_ct - end function gsw_pressure_freezing_ct - - elemental function gsw_pt0_cold_ice_poly (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt0_cold_ice_poly - end function gsw_pt0_cold_ice_poly - - elemental function gsw_pt0_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_pt0_from_t - end function gsw_pt0_from_t - - elemental function gsw_pt0_from_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_pt0_from_t_ice - end function gsw_pt0_from_t_ice - - elemental subroutine gsw_pt_first_derivatives (sa, ct, pt_sa, pt_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: pt_sa, pt_ct - end subroutine gsw_pt_first_derivatives - - elemental function gsw_pt_from_ct (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_pt_from_ct - end function gsw_pt_from_ct - - elemental function gsw_pt_from_entropy (sa, entropy) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, entropy - real (r8) :: gsw_pt_from_entropy - end function gsw_pt_from_entropy - - elemental function gsw_pt_from_pot_enthalpy_ice (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice - end function gsw_pt_from_pot_enthalpy_ice - - elemental function gsw_pt_from_pot_enthalpy_ice_poly_dh (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly_dh - end function gsw_pt_from_pot_enthalpy_ice_poly_dh - - elemental function gsw_pt_from_pot_enthalpy_ice_poly (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly - end function gsw_pt_from_pot_enthalpy_ice_poly - - elemental function gsw_pt_from_t (sa, t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p, p_ref - real (r8) :: gsw_pt_from_t - end function gsw_pt_from_t - - elemental function gsw_pt_from_t_ice (t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, p_ref - real (r8) :: gsw_pt_from_t_ice - end function gsw_pt_from_t_ice - - elemental subroutine gsw_pt_second_derivatives (sa, ct, pt_sa_sa, & - pt_sa_ct, pt_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: pt_sa_sa, pt_sa_ct, pt_ct_ct - end subroutine gsw_pt_second_derivatives - - elemental subroutine gsw_rho_alpha_beta (sa, ct, p, rho, alpha, beta) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho, alpha, beta - end subroutine gsw_rho_alpha_beta - - elemental function gsw_rho (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_rho - end function gsw_rho - - elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & - drho_dct, drho_dp) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp - end subroutine gsw_rho_first_derivatives - - elemental subroutine gsw_rho_first_derivatives_wrt_enthalpy (sa, ct, p, & - rho_sa, rho_h) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa, rho_h - end subroutine gsw_rho_first_derivatives_wrt_enthalpy - - elemental function gsw_rho_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_rho_ice - end function gsw_rho_ice - - elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & - rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct - real (r8), intent(out), optional :: rho_sa_p, rho_ct_p - end subroutine gsw_rho_second_derivatives - - elemental subroutine gsw_rho_second_derivatives_wrt_enthalpy (sa, ct, p, & - rho_sa_sa, rho_sa_h, rho_h_h) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa_sa, rho_sa_h, rho_h_h - end subroutine gsw_rho_second_derivatives_wrt_enthalpy - - elemental function gsw_rho_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_rho_t_exact - end function gsw_rho_t_exact - - pure subroutine gsw_rr68_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) - real (r8), intent(out) :: sa_i(:), ct_i(:) - end subroutine gsw_rr68_interp_sa_ct - - elemental function gsw_saar (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_saar - end function gsw_saar - - elemental function gsw_sa_freezing_estimate (p, saturation_fraction, ct, t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, saturation_fraction - real (r8), intent(in), optional :: ct, t - real (r8) :: gsw_sa_freezing_estimate - end function gsw_sa_freezing_estimate - - elemental function gsw_sa_freezing_from_ct (ct, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: ct, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_ct - end function gsw_sa_freezing_from_ct - - elemental function gsw_sa_freezing_from_ct_poly (ct, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: ct, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_ct_poly - end function gsw_sa_freezing_from_ct_poly - - elemental function gsw_sa_freezing_from_t (t, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_t - end function gsw_sa_freezing_from_t - - elemental function gsw_sa_freezing_from_t_poly (t, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_t_poly - end function gsw_sa_freezing_from_t_poly - - elemental function gsw_sa_from_rho (rho, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rho, ct, p - real (r8) :: gsw_sa_from_rho - end function gsw_sa_from_rho - - elemental function gsw_sa_from_sp_baltic (sp, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, long, lat - real (r8) :: gsw_sa_from_sp_baltic - end function gsw_sa_from_sp_baltic - - elemental function gsw_sa_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_sa_from_sp - end function gsw_sa_from_sp - - elemental function gsw_sa_from_sstar (sstar, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sstar, p, long, lat - real (r8) :: gsw_sa_from_sstar - end function gsw_sa_from_sstar - - elemental function gsw_sa_p_inrange (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - logical :: gsw_sa_p_inrange - end function gsw_sa_p_inrange - - elemental subroutine gsw_seaice_fraction_to_freeze_seawater (sa, ct, p, & - sa_seaice, t_seaice, sa_freeze, ct_freeze, w_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8), intent(out) :: sa_freeze, ct_freeze, w_seaice - end subroutine gsw_seaice_fraction_to_freeze_seawater - - elemental function gsw_sigma0 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma0 - end function gsw_sigma0 - - elemental function gsw_sigma1 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma1 - end function gsw_sigma1 - - elemental function gsw_sigma2 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma2 - end function gsw_sigma2 - - elemental function gsw_sigma3 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma3 - end function gsw_sigma3 - - elemental function gsw_sigma4 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma4 - end function gsw_sigma4 - - elemental function gsw_sound_speed (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_sound_speed - end function gsw_sound_speed - - elemental function gsw_sound_speed_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_sound_speed_ice - end function gsw_sound_speed_ice - - elemental function gsw_sound_speed_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_sound_speed_t_exact - end function gsw_sound_speed_t_exact - - elemental subroutine gsw_specvol_alpha_beta (sa, ct, p, specvol, alpha, & - beta) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: specvol, alpha, beta - end subroutine gsw_specvol_alpha_beta - - elemental function gsw_specvol_anom_standard (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_specvol_anom_standard - end function gsw_specvol_anom_standard - - elemental function gsw_specvol (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_specvol - end function gsw_specvol - - elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & - v_p, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa, v_ct, v_p - end subroutine gsw_specvol_first_derivatives - - elemental subroutine gsw_specvol_first_derivatives_wrt_enthalpy (sa, ct, & - p, v_sa, v_h, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa, v_h - end subroutine gsw_specvol_first_derivatives_wrt_enthalpy - - elemental function gsw_specvol_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_specvol_ice - end function gsw_specvol_ice - - elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & - v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p - end subroutine gsw_specvol_second_derivatives - - elemental subroutine gsw_specvol_second_derivatives_wrt_enthalpy (sa, ct, & - p, v_sa_sa, v_sa_h, v_h_h, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa_sa, v_sa_h, v_h_h - end subroutine gsw_specvol_second_derivatives_wrt_enthalpy - - elemental function gsw_specvol_sso_0 (p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p - real (r8) :: gsw_specvol_sso_0 - end function gsw_specvol_sso_0 - - elemental function gsw_specvol_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_specvol_t_exact - end function gsw_specvol_t_exact - - elemental function gsw_sp_from_c (c, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: c, t, p - real (r8) :: gsw_sp_from_c - end function gsw_sp_from_c - - elemental function gsw_sp_from_sa_baltic (sa, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, long, lat - real (r8) :: gsw_sp_from_sa_baltic - end function gsw_sp_from_sa_baltic - - elemental function gsw_sp_from_sa (sa, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, long, lat - real (r8) :: gsw_sp_from_sa - end function gsw_sp_from_sa - - elemental function gsw_sp_from_sk (sk) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sk - real (r8) :: gsw_sp_from_sk - end function gsw_sp_from_sk - - elemental function gsw_sp_from_sr (sr) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sr - real (r8) :: gsw_sp_from_sr - end function gsw_sp_from_sr - - elemental function gsw_sp_from_sstar (sstar, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sstar, p, long, lat - real (r8) :: gsw_sp_from_sstar - end function gsw_sp_from_sstar - - elemental function gsw_spiciness0 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness0 - end function gsw_spiciness0 - - elemental function gsw_spiciness1 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness1 - end function gsw_spiciness1 - - elemental function gsw_spiciness2 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness2 - end function gsw_spiciness2 - - elemental function gsw_sr_from_sp (sp) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp - real (r8) :: gsw_sr_from_sp - end function gsw_sr_from_sp - - elemental function gsw_sstar_from_sa (sa, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, long, lat - real (r8) :: gsw_sstar_from_sa - end function gsw_sstar_from_sa - - elemental function gsw_sstar_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_sstar_from_sp - end function gsw_sstar_from_sp - - elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_t_deriv_chem_potential_water_t_exact - end function gsw_t_deriv_chem_potential_water_t_exact - - elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_t_freezing_exact - end function gsw_t_freezing_exact - - elemental function gsw_t_freezing (sa, p, saturation_fraction, poly) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - logical, intent(in), optional :: poly - real (r8) :: gsw_t_freezing - end function gsw_t_freezing - - elemental subroutine gsw_t_freezing_first_derivatives (sa, p, & - saturation_fraction, tfreezing_sa, tfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p - end subroutine gsw_t_freezing_first_derivatives - - elemental subroutine gsw_t_freezing_first_derivatives_poly (sa, p, & - saturation_fraction, tfreezing_sa, tfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p - end subroutine gsw_t_freezing_first_derivatives_poly - - elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(in), optional :: saturation_fraction - logical, intent(in), optional :: polynomial - real (r8) :: gsw_t_freezing_poly - end function gsw_t_freezing_poly - - elemental function gsw_t_from_ct (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_t_from_ct - end function gsw_t_from_ct - - elemental function gsw_t_from_pt0_ice (pt0_ice, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice, p - real (r8) :: gsw_t_from_pt0_ice - end function gsw_t_from_pt0_ice - - elemental function gsw_thermobaric (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_thermobaric - end function gsw_thermobaric - - pure subroutine gsw_turner_rsubrho (sa, ct, p, tu, rsubrho, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:) - real (r8), intent(out) :: tu(:), rsubrho(:), p_mid(:) - end subroutine gsw_turner_rsubrho - - pure subroutine gsw_util_indx (x, n, z, k) - use gsw_mod_kinds - integer, intent(in) :: n - integer, intent(out) :: k - real (r8), intent(in), dimension(n) :: x - real (r8), intent(in) :: z - end subroutine gsw_util_indx - - pure function gsw_util_interp1q_int (x, iy, x_i) result(y_i) - use gsw_mod_kinds - implicit none - integer, intent(in) :: iy(:) - real (r8), intent(in) :: x(:), x_i(:) - real (r8) :: y_i(size(x_i)) - end function gsw_util_interp1q_int - - pure function gsw_util_sort_real (rarray) result(iarray) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rarray(:) ! Values to be sorted - integer :: iarray(size(rarray)) ! Sorted ids - end function gsw_util_sort_real - - pure function gsw_util_xinterp1 (x, y, n, x0) - use gsw_mod_kinds - implicit none - integer, intent(in) :: n - real (r8), intent(in) :: x0 - real (r8), dimension(n), intent(in) :: x, y - real (r8) :: gsw_util_xinterp1 - end function gsw_util_xinterp1 - - elemental function gsw_z_from_p (p, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, lat - real (r8) :: gsw_z_from_p - end function gsw_z_from_p - -end interface - -end module gsw_mod_toolbox diff --git a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 new file mode 120000 index 0000000000..f2f4761ec4 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_toolbox.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 deleted file mode 100644 index 63c2c83292..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 +++ /dev/null @@ -1,59 +0,0 @@ -!========================================================================== -elemental function gsw_pt0_from_t (sa, t, p) -!========================================================================== -! -! Calculates potential temperature with reference pressure, p_ref = 0 dbar. -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_pt0_from_t : potential temperature, p_ref = 0 [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_entropy_part, gsw_entropy_part_zerop -use gsw_mod_toolbox, only : gsw_gibbs_pt0_pt0 - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_pt0_from_t - -integer n, no_iter -real (r8) :: s1, true_entropy_part, pt0m -real (r8) :: pt0, pt0_old, de_dt, dentropy, dentropy_dt - -s1 = sa/gsw_ups - -pt0 = t + p*( 8.65483913395442e-6_r8 - & - s1 * 1.41636299744881e-6_r8 - & - p * 7.38286467135737e-9_r8 + & - t *(-8.38241357039698e-6_r8 + & - s1 * 2.83933368585534e-8_r8 + & - t * 1.77803965218656e-8_r8 + & - p * 1.71155619208233e-10_r8)) - -dentropy_dt = gsw_cp0/((gsw_t0 + pt0)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) - -true_entropy_part = gsw_entropy_part(sa,t,p) - -do no_iter = 1, 2 - pt0_old = pt0 - dentropy = gsw_entropy_part_zerop(sa,pt0_old) - true_entropy_part - pt0 = pt0_old - dentropy/dentropy_dt - pt0m = 0.5_r8*(pt0 + pt0_old) - dentropy_dt = -gsw_gibbs_pt0_pt0(sa,pt0m) - pt0 = pt0_old - dentropy/dentropy_dt -end do - -gsw_pt0_from_t = pt0 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 new file mode 120000 index 0000000000..79cf5b0d65 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt0_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 deleted file mode 100644 index b856b923c8..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 +++ /dev/null @@ -1,72 +0,0 @@ -!========================================================================== -elemental function gsw_pt_from_ct (sa, ct) -!========================================================================== -! -! potential temperature of seawater from conservative temperature -! -! sa : Absolute Salinity [g/kg] -! ct : Conservative Temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_pt_from_ct : potential temperature with [deg C] -! reference pressure of 0 dbar -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_gibbs_pt0_pt0 - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_ups, gsw_t0 - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct - -real (r8) :: gsw_pt_from_ct - -real (r8) :: a5ct, b3ct, ct_factor, pt_num, pt_recden, ct_diff -real (r8) :: ct0, pt, pt_old, ptm, dct, dpt_dct, s1 - -real (r8), parameter :: a0 = -1.446013646344788e-2_r8 -real (r8), parameter :: a1 = -3.305308995852924e-3_r8 -real (r8), parameter :: a2 = 1.062415929128982e-4_r8 -real (r8), parameter :: a3 = 9.477566673794488e-1_r8 -real (r8), parameter :: a4 = 2.166591947736613e-3_r8 -real (r8), parameter :: a5 = 3.828842955039902e-3_r8 - -real (r8), parameter :: b0 = 1.0_r8 -real (r8), parameter :: b1 = 6.506097115635800e-4_r8 -real (r8), parameter :: b2 = 3.830289486850898e-3_r8 -real (r8), parameter :: b3 = 1.247811760368034e-6_r8 - -s1 = sa/gsw_ups - -a5ct = a5*ct -b3ct = b3*ct - -ct_factor = (a3 + a4*s1 + a5ct) -pt_num = a0 + s1*(a1 + a2*s1) + ct*ct_factor -pt_recden = 1.0_r8/(b0 + b1*s1 + ct*(b2 + b3ct)) -pt = pt_num*pt_recden - -dpt_dct = (ct_factor + a5ct - (b2 + b3ct + b3ct)*pt)*pt_recden - -! Start the 1.5 iterations through the modified Newton-Rapshon iterative, -! method, which is also known as the Newton-McDougall method. - -ct_diff = gsw_ct_from_pt(sa,pt) - ct -pt_old = pt -pt = pt_old - ct_diff*dpt_dct -ptm = 0.5_r8*(pt + pt_old) - -dpt_dct = -gsw_cp0/((ptm + gsw_t0)*gsw_gibbs_pt0_pt0(sa,ptm)) - -pt = pt_old - ct_diff*dpt_dct -ct_diff = gsw_ct_from_pt(sa,pt) - ct -pt_old = pt -gsw_pt_from_ct = pt_old - ct_diff*dpt_dct - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 new file mode 120000 index 0000000000..cd794a1316 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt_from_ct.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 deleted file mode 100644 index 46dc766fb6..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 +++ /dev/null @@ -1,61 +0,0 @@ -!========================================================================== -elemental function gsw_pt_from_t (sa, t, p, p_ref) -!========================================================================== -! -! Calculates potential temperature of seawater from in-situ temperature -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! p_ref : reference sea pressure [dbar] -! -! gsw_pt_from_t : potential temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_entropy_part, gsw_gibbs - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p, p_ref - -real (r8) :: gsw_pt_from_t - -integer n, no_iter -real (r8) :: s1, pt, pt_old, de_dt, dentropy, dentropy_dt -real (r8) :: true_entropy_part, ptm - -integer, parameter :: n0=0, n2=2 - -s1 = sa/gsw_ups - -pt = t + (p-p_ref)*( 8.65483913395442e-6_r8 - & - s1 * 1.41636299744881e-6_r8 - & - (p+p_ref)* 7.38286467135737e-9_r8 + & - t *(-8.38241357039698e-6_r8 + & - s1 * 2.83933368585534e-8_r8 + & - t * 1.77803965218656e-8_r8 + & - (p+p_ref)* 1.71155619208233e-10_r8)) - -dentropy_dt = gsw_cp0/((gsw_t0 + pt)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) - -true_entropy_part = gsw_entropy_part(sa,t,p) - -do no_iter = 1, 2 - pt_old = pt - dentropy = gsw_entropy_part(sa,pt_old,p_ref) - true_entropy_part - pt = pt_old - dentropy/dentropy_dt - ptm = 0.5_r8*(pt + pt_old) - dentropy_dt = -gsw_gibbs(n0,n2,n0,sa,ptm,p_ref) - pt = pt_old - dentropy/dentropy_dt -end do - -gsw_pt_from_t = pt - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 new file mode 120000 index 0000000000..37fa5f104f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho.f90 b/src/equation_of_state/TEOS10/gsw_rho.f90 deleted file mode 100644 index 3daa65746e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho.f90 +++ /dev/null @@ -1,36 +0,0 @@ -!========================================================================== -elemental function gsw_rho (sa, ct, p) -!========================================================================== -! -! Calculates in-situ density from Absolute Salinity and Conservative -! Temperature, using the computationally-efficient expression for -! specific volume in terms of SA, CT and p (Roquet et al., 2014). -! -! Note that potential density with respect to reference pressure, pr, is -! obtained by calling this function with the pressure argument being pr -! (i.e. "gsw_rho(SA,CT,pr)"). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! rho = in-situ density [ kg/m ] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_specvol - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_rho - -gsw_rho = 1.0_r8/gsw_specvol(sa,ct,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho.f90 b/src/equation_of_state/TEOS10/gsw_rho.f90 new file mode 120000 index 0000000000..22eea6219a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 deleted file mode 100644 index b4ee696a1d..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 +++ /dev/null @@ -1,110 +0,0 @@ -!========================================================================== -elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & - drho_dct, drho_dp) -!========================================================================== -! -! Calculates the three (3) partial derivatives of in-situ density with -! respect to Absolute Salinity, Conservative Temperature and pressure. -! Note that the pressure derivative is done with respect to pressure in -! Pa, not dbar. This function uses the computationally-efficient expression -! for specific volume in terms of SA, CT and p (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! drho_dSA = partial derivatives of density [ kg^2/(g m^3) ] -! with respect to Absolute Salinity -! drho_dCT = partial derivatives of density [ kg/(K m^3) ] -! with respect to Conservative Temperature -! drho_dP = partial derivatives of density [ kg/(Pa m^3) ] -! with respect to pressure in Pa -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : pa2db, gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp - -real (r8) :: rho2, v_ct, v_p, v_sa, xs, ys, z, v - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -v = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & - + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & - + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & - + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & - + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & - + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & - + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & - + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & - + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & - + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & - + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & - + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & - + z*(v005 + v006*z))))) - -rho2 = (1.0_r8/v)**2 - -if (present(drho_dsa)) then - - v_sa = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & - + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & - + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & - + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & - + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & - + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & - + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & - + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & - + z*(b003 + b103*xs + b013*ys + b004*z))) - - drho_dsa = -rho2*0.5_r8*gsw_sfac*v_sa/xs - -end if - -if (present(drho_dct)) then - - v_ct = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & - + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & - + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & - + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & - + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & - + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & - + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & - + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & - + z*(a003 + a103*xs + a013*ys + a004*z))) - - drho_dct = -rho2*0.025_r8*v_ct - -end if - -if (present(drho_dp)) then - - v_p = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & - + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & - + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & - + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & - + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & - + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & - + z*(c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & - + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) - - drho_dp = -rho2*1e-4_r8*pa2db*v_p - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 new file mode 120000 index 0000000000..3a8ba38824 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho_first_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 deleted file mode 100644 index fdf75e7a0a..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!========================================================================== -elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & - rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) -!========================================================================== -! -! Calculates five second-order derivatives of rho. Note that this function -! uses the using the computationally-efficient expression for specific -! volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! rho_SA_SA = The second-order derivative of rho with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! rho_SA_CT = The second-order derivative of rho with respect to -! SA and CT at constant p. [ J/(kg K(g/kg)) ] -! rho_CT_CT = The second-order derivative of rho with respect to CT at -! constant SA & p -! rho_SA_P = The second-order derivative with respect to SA & P at -! constant CT. -! rho_CT_P = The second-order derivative with respect to CT & P at -! constant SA. -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_specvol, gsw_specvol_first_derivatives -use gsw_mod_toolbox, only : gsw_specvol_second_derivatives - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct -real (r8), intent(out), optional :: rho_sa_p, rho_ct_p - -integer :: iflag1, iflag2 -real (r8) :: rec_v, rec_v2, rec_v3, v_ct, v_ct_ct, v_ct_p, v_p, v_sa, v_sa_ct -real (r8) :: v_sa_p, v_sa_sa - -iflag1 = 0 -if (present(rho_sa_sa) .or. present(rho_sa_ct) & - .or. present(rho_sa_p)) iflag1 = ibset(iflag1,1) -if (present(rho_sa_ct) .or. present(rho_ct_ct) & - .or. present(rho_ct_p)) iflag1 = ibset(iflag1,2) -if (present(rho_sa_p) .or. present(rho_ct_p)) iflag1 = ibset(iflag1,3) - -call gsw_specvol_first_derivatives(sa,ct,p,v_sa,v_ct,v_p,iflag=iflag1) - -iflag2 = 0 -if (present(rho_sa_sa)) iflag2 = ibset(iflag2,1) -if (present(rho_sa_ct)) iflag2 = ibset(iflag2,2) -if (present(rho_ct_ct)) iflag2 = ibset(iflag2,3) -if (present(rho_sa_p)) iflag2 = ibset(iflag2,4) -if (present(rho_ct_p)) iflag2 = ibset(iflag2,5) - -call gsw_specvol_second_derivatives(sa,ct,p,v_sa_sa,v_sa_ct,v_ct_ct, & - v_sa_p,v_ct_p,iflag=iflag2) - -rec_v = 1.0_r8/gsw_specvol(sa,ct,p) -rec_v2 = rec_v**2 -rec_v3 = rec_v2*rec_v - -if (present(rho_sa_sa)) rho_sa_sa = -v_sa_sa*rec_v2 + 2.0_r8*v_sa*v_sa*rec_v3 - -if (present(rho_sa_ct)) rho_sa_ct = -v_sa_ct*rec_v2 + 2.0_r8*v_sa*v_ct*rec_v3 - -if (present(rho_ct_ct)) rho_ct_ct = -v_ct_ct*rec_v2 + 2.0_r8*v_ct*v_ct*rec_v3 - -if (present(rho_sa_p)) rho_sa_p = -v_sa_p*rec_v2 + 2.0_r8*v_sa*v_p*rec_v3 - -if (present(rho_ct_p)) rho_ct_p = -v_ct_p*rec_v2 + 2.0_r8*v_ct*v_p*rec_v3 - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 new file mode 120000 index 0000000000..8b38e0f56f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho_second_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 deleted file mode 100644 index c01377546c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -elemental function gsw_sp_from_sr (sr) -!========================================================================== -! -! Calculates Practical Salinity, sp, from Reference Salinity, sr. -! -! sr : Reference Salinity [g/kg] -! -! gsw_sp_from_sr : Practical Salinity [unitless] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sr - -real (r8) :: gsw_sp_from_sr - -gsw_sp_from_sr = sr/gsw_ups - -return -end function - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 new file mode 120000 index 0000000000..d8cd41f4bf --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_sp_from_sr.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol.f90 b/src/equation_of_state/TEOS10/gsw_specvol.f90 deleted file mode 100644 index 00cfaab125..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol.f90 +++ /dev/null @@ -1,52 +0,0 @@ -!========================================================================== -elemental function gsw_specvol (sa, ct, p) -!========================================================================== -! -! Calculates specific volume from Absolute Salinity, Conservative -! Temperature and pressure, using the computationally-efficient -! polynomial expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! specvol = specific volume [ m^3/kg ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_specvol - -real (r8) :: xs, ys, z - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -gsw_specvol = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & - + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & - + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & - + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & - + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & - + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & - + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & - + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & - + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & - + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & - + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & - + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & - + z*(v005 + v006*z))))) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol.f90 b/src/equation_of_state/TEOS10/gsw_specvol.f90 new file mode 120000 index 0000000000..7a41a5cea0 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 deleted file mode 100644 index 2f2a006b17..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 +++ /dev/null @@ -1,104 +0,0 @@ -!========================================================================== -elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & - v_p, iflag) -! ========================================================================= -! -! Calculates three first-order derivatives of specific volume (v). -! Note that this function uses the computationally-efficient -! expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! v_SA = The first derivative of specific volume with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! v_CT = The first derivative of specific volume with respect to -! CT at constant SA and p. [ J/(kg K(g/kg)) ] -! v_P = The first derivative of specific volume with respect to -! P at constant SA and CT. [ J/(kg K^2) ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -integer, intent(in), optional :: iflag -real (r8), intent(out), optional :: v_sa, v_ct, v_p - -integer :: i -logical :: flags(3) -real (r8) :: v_ct_part, v_p_part, v_sa_part, xs, ys, z - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -if (present(iflag)) then - do i = 1, 3 - flags(i) = btest(iflag,i) - end do -else - flags = .true. -end if - -if (present(v_sa) .and. flags(1)) then - - v_sa_part = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & - + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & - + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & - + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & - + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & - + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & - + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & - + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & - + z*(b003 + b103*xs + b013*ys + b004*z))) - - v_sa = 0.5_r8*gsw_sfac*v_sa_part/xs - -end if - - -if (present(v_ct) .and. flags(2)) then - - v_ct_part = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & - + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & - + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & - + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & - + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & - + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & - + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & - + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & - + z*(a003 + a103*xs + a013*ys + a004*z))) - - v_ct = 0.025_r8*v_ct_part - -end if - -if (present(v_p) .and. flags(3)) then - - v_p_part = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & - + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & - + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & - + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & - + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & - + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & - + z*( c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & - + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) - - v_p = 1e-8_r8*v_p_part - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 new file mode 120000 index 0000000000..ee6ee1f906 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol_first_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 deleted file mode 100644 index 39096109e9..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 +++ /dev/null @@ -1,131 +0,0 @@ -!========================================================================== -elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & - v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) -! ========================================================================= -! -! Calculates five second-order derivatives of specific volume (v). -! Note that this function uses the computationally-efficient -! expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! v_SA_SA = The second derivative of specific volume with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! v_SA_CT = The second derivative of specific volume with respect to -! SA and CT at constant p. [ J/(kg K(g/kg)) ] -! v_CT_CT = The second derivative of specific volume with respect to -! CT at constant SA and p. [ J/(kg K^2) ] -! v_SA_P = The second derivative of specific volume with respect to -! SA and P at constant CT. [ J/(kg K(g/kg)) ] -! v_CT_P = The second derivative of specific volume with respect to -! CT and P at constant SA. [ J/(kg K(g/kg)) ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -integer, intent(in), optional :: iflag -real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p - -integer :: i -logical :: flags(5) -real (r8) :: v_ct_ct_part, v_ct_p_part, v_sa_ct_part, v_sa_p_part -real (r8) :: v_sa_sa_part, xs, xs2, ys, z - -xs2 = gsw_sfac*sa + offset -xs = sqrt(xs2) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -if (present(iflag)) then - do i = 1, 5 - flags(i) = btest(iflag,i) - end do -else - flags = .true. -end if - -if (present(v_sa_sa) .and. flags(1)) then - - v_sa_sa_part = (-b000 + xs2*(b200 + xs*(2.0_r8*b300 + xs*(3.0_r8*b400 & - + 4.0_r8*b500*xs))) + ys*(-b010 + xs2*(b210 + xs*(2.0_r8*b310 & - + 3.0_r8*b410*xs)) + ys*(-b020 + xs2*(b220 + 2.0_r8*b320*xs) & - + ys*(-b030 + b230*xs2 + ys*(-b040 - b050*ys)))) + z*(-b001 & - + xs2*(b201 + xs*(2.0_r8*b301 + 3.0_r8*b401*xs)) + ys*(-b011 & - + xs2*(b211 + 2.0_r8*b311*xs) + ys*(-b021 + b221*xs2 & - + ys*(-b031 - b041*ys))) + z*(-b002 + xs2*(b202 + 2.0_r8*b302*xs) & - + ys*(-b012 + b212*xs2 + ys*(-b022 - b032*ys)) + z*(-b003 & - - b013*ys - b004*z))))/xs2 - - v_sa_sa = 0.25_r8*gsw_sfac*gsw_sfac*v_sa_sa_part/xs - -end if - -if (present(v_sa_ct) .and. flags(2)) then - - v_sa_ct_part = (b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(2.0_r8*(b020 + xs*(b120 + xs*(b220 + b320*xs))) & - + ys*(3.0_r8*(b030 + xs*(b130 + b230*xs)) + ys*(4.0_r8*(b040 + b140*xs) & - + 5.0_r8*b050*ys))) + z*(b011 + xs*(b111 + xs*(b211 + b311*xs)) & - + ys*(2.0_r8*(b021 + xs*(b121 + b221*xs)) + ys*(3.0_r8*(b031 + b131*xs) & - + 4.0_r8*b041*ys)) + z*(b012 + xs*(b112 + b212*xs) + ys*(2.0_r8*(b022 & - + b122*xs) + 3.0_r8*b032*ys) + b013*z)))/xs - - v_sa_ct = 0.025_r8*0.5_r8*gsw_sfac*v_sa_ct_part - -end if - -if (present(v_ct_ct) .and. flags(3)) then - - v_ct_ct_part = a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(2.0_r8*(a020 + xs*(a120 + xs*(a220 + a320*xs))) & - + ys*(3.0_r8*(a030 + xs*(a130 + a230*xs)) + ys*(4.0_r8*(a040 & - + a140*xs) + 5.0_r8*a050*ys))) + z*( a011 + xs*(a111 + xs*(a211 & - + a311*xs)) + ys*(2.0_r8*(a021 + xs*(a121 + a221*xs)) & - + ys*(3.0_r8*(a031 + a131*xs) + 4.0_r8*a041*ys)) + z*(a012 & - + xs*(a112 + a212*xs) + ys*(2.0_r8*(a022 + a122*xs) & - + 3.0_r8*a032*ys) + a013*z)) - - v_ct_ct = 0.025_r8*0.025_r8*v_ct_ct_part - -end if - -if (present(v_sa_p) .and. flags(4)) then - - v_sa_p_part = b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) + ys*(b011 & - + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 + xs*(b121 + b221*xs) & - + ys*(b031 + b131*xs + b041*ys))) + z*(2.0_r8*(b002 + xs*(b102 & - + xs*(b202 + b302*xs)) + ys*(b012 + xs*(b112 + b212*xs) + ys*(b022 & - + b122*xs + b032*ys))) + z*(3.0_r8*(b003 + b103*xs + b013*ys) & - + 4.0_r8*b004*z)) - - v_sa_p = 1e-8_r8*0.5_r8*gsw_sfac*v_sa_p_part - -end if - -if (present(v_ct_p) .and. flags(5)) then - - v_ct_p_part = a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) + ys*(a011 & - + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 + xs*(a121 + a221*xs) & - + ys*(a031 + a131*xs + a041*ys))) + z*(2.0_r8*(a002 + xs*(a102 & - + xs*(a202 + a302*xs)) + ys*(a012 + xs*(a112 + a212*xs) + ys*(a022 & - + a122*xs + a032*ys))) + z*(3.0_r8*(a003 + a103*xs + a013*ys) & - + 4.0_r8*a004*z)) - - v_ct_p = 1e-8_r8*0.025_r8*v_ct_p_part - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 new file mode 120000 index 0000000000..cdd1c1b87a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol_second_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 deleted file mode 100644 index cbcc4fea0b..0000000000 --- a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -elemental function gsw_sr_from_sp (sp) -!========================================================================== -! -! Calculates Reference Salinity, SR, from Practical Salinity, SP. -! -! sp : Practical Salinity [unitless] -! -! gsw_sr_from_sp : Reference Salinity [g/kg] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sp - -real (r8) :: gsw_sr_from_sp - -gsw_sr_from_sp = sp*gsw_ups - -return -end function - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 new file mode 120000 index 0000000000..eda229ff66 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_sr_from_sp.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 deleted file mode 100644 index 668184491f..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 +++ /dev/null @@ -1,88 +0,0 @@ -!========================================================================== -elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) -!========================================================================== -! -! Calculates the temperature derivative of the chemical potential of water -! in seawater so that it is valid at exactly SA = 0. -! -! SA = Absolute Salinity [ g/kg ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! chem_potential_water_dt = temperature derivative of the chemical -! potential of water in seawater [ J g^-1 K^-1 ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, rec_db2pa - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_t_deriv_chem_potential_water_t_exact - -real (r8) :: g03_t, g08_sa_t, x, x2, y, z, g08_t - -real (r8), parameter :: kg2g = 1e-3_r8 - -! Note. The kg2g, a factor of 1e-3, is needed to convert the output of this -! function into units of J/g. See section (2.9) of the TEOS-10 Manual. - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*rec_db2pa ! the input pressure (p) is sea pressure in units of dbar. - -g03_t = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - & - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + & - z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + & - (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - & - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + & - 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - & - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + & - 49.023632509086724_r8*z))))))) - -g08_t = x2*(168.072408311545_r8 + & - x*(-493.407510141682_r8 + x*(543.835333000098_r8 + & - x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & - y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & - y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + & - (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + & - z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & - y*(3.50240264723578_r8 + 938.26075044542_r8*z))))) - -g08_sa_t = 1187.3715515697959_r8 + & - x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + & - x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & - y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + & - y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & - 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + & - (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + & - z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & - y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + & - y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) - -gsw_t_deriv_chem_potential_water_t_exact = kg2g*((g03_t + g08_t)*0.025_r8 - & - 0.5_r8*gsw_sfac*0.025_r8*sa*g08_sa_t) -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 new file mode 120000 index 0000000000..3194f69a64 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_deriv_chem_potential_water_t_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 deleted file mode 100644 index 63c27db986..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 +++ /dev/null @@ -1,71 +0,0 @@ -!========================================================================== -elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the in-situ temperature at which seawater freezes. The -! in-situ temperature freezing point is calculated from the exact -! in-situ freezing temperature which is found by a modified Newton-Raphson -! iteration (McDougall and Wotherspoon, 2013) of the equality of the -! chemical potentials of water in seawater and in ice. -! -! An alternative GSW function, gsw_t_freezing_poly, it is based on a -! computationally-efficient polynomial, and is accurate to within -5e-4 K -! and 6e-4 K, when compared with this function. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! (i.e., saturation_fraction must be between 0 and 1, and the default -! is 1, completely saturated) -! -! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_toolbox, only : gsw_gibbs_ice, gsw_chem_potential_water_t_exact -use gsw_mod_toolbox, only : gsw_t_deriv_chem_potential_water_t_exact -use gsw_mod_toolbox, only : gsw_t_freezing_poly - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_t_freezing_exact - -real (r8) :: df_dt, p_r, sa_r, tf, tfm, tf_old, x, f - -! The initial value of t_freezing_exact (for air-free seawater) -tf = gsw_t_freezing_poly(sa,p,polynomial=.true.) - -df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tf,p) - & - gsw_gibbs_ice(1,0,tf,p) -! df_dt here is the initial value of the derivative of the function f whose -! zero (f = 0) we are finding (see Eqn. (3.33.2) of IOC et al (2010)). - -tf_old = tf -f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & - gsw_gibbs_ice(0,0,tf_old,p) -tf = tf_old - f/df_dt -tfm = 0.5_r8*(tf + tf_old) -df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tfm,p) - & - gsw_gibbs_ice(1,0,tfm,p) -tf = tf_old - f/df_dt - -tf_old = tf -f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & - gsw_gibbs_ice(0,0,tf_old,p) -tf = tf_old - f/df_dt - -! Adjust for the effects of dissolved air -gsw_t_freezing_exact = tf - & - saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 new file mode 120000 index 0000000000..ca5434983f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_freezing_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 deleted file mode 100644 index 479a323d2c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!========================================================================== -elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) -!========================================================================== -! -! Calculates the in-situ temperature at which seawater freezes from a -! computationally efficient polynomial. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] -! (ITS-90) -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_freezing_poly_coefficients - -use gsw_mod_toolbox, only : gsw_ct_freezing_poly, gsw_t_from_ct - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p -real (r8), intent(in), optional :: saturation_fraction -logical, intent(in), optional :: polynomial - -real (r8) :: gsw_t_freezing_poly - -real (r8) :: p_r, sa_r, x, ctf, sfrac -logical :: direct_poly - -if (present(polynomial)) then - direct_poly = polynomial -else - direct_poly = .false. -end if - -if (.not. direct_poly) then - - if (present(saturation_fraction)) then - sfrac = saturation_fraction - else - sfrac = 1.0_r8 - end if - - ctf = gsw_ct_freezing_poly(sa,p,sfrac) - gsw_t_freezing_poly = gsw_t_from_ct(sa,ctf,p) - -else - - ! Alternative calculation ... - sa_r = sa*1e-2_r8 - x = sqrt(sa_r) - p_r = p*1e-4_r8 - - gsw_t_freezing_poly = t0 & - + sa_r*(t1 + x*(t2 + x*(t3 + x*(t4 + x*(t5 + t6*x))))) & - + p_r*(t7 + p_r*(t8 + t9*p_r)) & - + sa_r*p_r*(t10 + p_r*(t12 + p_r*(t15 + t21*sa_r)) & - + sa_r*(t13 + t17*p_r + t19*sa_r) & - + x*(t11 + p_r*(t14 + t18*p_r) + sa_r*(t16 + t20*p_r + t22*sa_r))) - - if (.not. present(saturation_fraction)) return - - ! Adjust for the effects of dissolved air - gsw_t_freezing_poly = gsw_t_freezing_poly - & - saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 new file mode 120000 index 0000000000..fcc75a7d80 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_freezing_poly.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 deleted file mode 100644 index 9f85a4530c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 +++ /dev/null @@ -1,33 +0,0 @@ -!========================================================================== -elemental function gsw_t_from_ct (sa, ct, p) -!========================================================================== -! -! Calculates in-situ temperature from Conservative Temperature of seawater -! -! sa : Absolute Salinity [g/kg] -! ct : Conservative Temperature [deg C] -! -! gsw_t_from_ct : in-situ temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_pt_from_ct, gsw_pt_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_t_from_ct - -real (r8) :: pt0 - -real (r8), parameter :: p0 = 0.0_r8 - -pt0 = gsw_pt_from_ct(sa,ct) -gsw_t_from_ct = gsw_pt_from_t(sa,pt0,p0,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 new file mode 120000 index 0000000000..41a33a07b5 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_from_ct.f90 \ No newline at end of file diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 368a6b773b..2a71e7cda5 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -33,7 +33,7 @@ module MOM_diag_mediator use diag_axis_mod, only : get_diag_axis_name use diag_data_mod, only : null_axis_id use diag_manager_mod, only : diag_manager_init, diag_manager_end -use diag_manager_mod, only : send_data, diag_axis_init, diag_field_add_attribute +use diag_manager_mod, only : send_data, diag_axis_init, EAST, NORTH, diag_field_add_attribute ! The following module is needed for PGI since the following line does not compile with PGI 6.5.0 ! was: use diag_manager_mod, only : register_diag_field_fms=>register_diag_field use MOM_diag_manager_wrapper, only : register_diag_field_fms @@ -365,14 +365,14 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, 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) + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) else id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain) + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) endif id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & 'h point nominal longitude', Domain2=G%Domain%mpp_domain) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 1a732533b0..15d0839ee9 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -85,7 +85,7 @@ end subroutine doc_param_none !> This subroutine handles parameter documentation for logicals. subroutine doc_param_logical(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -95,6 +95,8 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & logical, optional, intent(in) :: default !< The default value of this parameter 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for logicals. character(len=mLen) :: mesg logical :: equalsDefault @@ -110,6 +112,7 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & endif equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val .eqv. default) equalsDefault = .true. if (default) then @@ -127,7 +130,7 @@ end subroutine doc_param_logical !> This subroutine handles parameter documentation for arrays of logicals. subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -137,6 +140,8 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & logical, optional, intent(in) :: default !< The default value of this parameter 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of logicals. integer :: i character(len=mLen) :: mesg @@ -158,7 +163,7 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & mesg = define_string(doc, varname, valstring, units) - equalsDefault = .false. + equalsDefault = .false. if (present(default)) then equalsDefault = .true. do i=1,size(vals) ; if (vals(i) .neqv. default) equalsDefault = .false. ; enddo @@ -168,6 +173,7 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & mesg = trim(mesg)//" default = "//STRING_FALSE endif endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & @@ -177,7 +183,7 @@ end subroutine doc_param_logical_array !> This subroutine handles parameter documentation for integers. subroutine doc_param_int(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -187,6 +193,8 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & integer, optional, intent(in) :: default !< The default value of this parameter 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for integers. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -200,6 +208,7 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//(trim(int_string(default))) @@ -213,7 +222,7 @@ end subroutine doc_param_int !> This subroutine handles parameter documentation for arrays of integers. subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -223,6 +232,8 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & integer, optional, intent(in) :: default !< The default value of this parameter 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of integers. integer :: i character(len=mLen) :: mesg @@ -246,6 +257,7 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//(trim(int_string(default))) endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & @@ -255,7 +267,7 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & end subroutine doc_param_int_array !> This subroutine handles parameter documentation for reals. -subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam) +subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -264,6 +276,8 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara real, intent(in) :: val !< The value of this parameter real, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for reals. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -277,6 +291,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//trim(real_string(default)) @@ -288,7 +303,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara end subroutine doc_param_real !> This subroutine handles parameter documentation for arrays of reals. -subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam) +subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -297,6 +312,8 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg real, intent(in) :: vals(:) !< The array of values to record real, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of reals. integer :: i character(len=mLen) :: mesg @@ -317,6 +334,7 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//trim(real_string(default)) endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) @@ -326,7 +344,7 @@ end subroutine doc_param_real_array !> This subroutine handles parameter documentation for character strings. subroutine doc_param_char(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -337,6 +355,8 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & optional, intent(in) :: default !< The default value of this parameter 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for character strings. character(len=mLen) :: mesg logical :: equalsDefault @@ -348,6 +368,7 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & mesg = define_string(doc, varname, '"'//trim(val)//'"', units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (trim(val) == trim(default)) equalsDefault = .true. mesg = trim(mesg)//' default = "'//trim(adjustl(default))//'"' @@ -412,7 +433,7 @@ subroutine doc_closeBlock(doc, blockName) end subroutine doc_closeBlock !> This subroutine handles parameter documentation for time-type variables. -subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingParam) +subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -421,6 +442,8 @@ subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingPara type(time_type), optional, intent(in) :: default !< The default value of this parameter character(len=*), optional, intent(in) :: units !< The units of the parameter being documented logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! Local varables character(len=mLen) :: mesg ! The output message @@ -439,6 +462,7 @@ subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingPara endif equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//trim(time_string(default)) @@ -776,7 +800,9 @@ subroutine doc_module(doc, modname, desc, log_to_all, all_default, layoutMod, de call open_doc_file(doc) if (doc%filesAreOpen) then - call writeMessageAndDesc(doc, '', '') ! Blank line for delineation + ! Add a blank line for delineation + call writeMessageAndDesc(doc, '', '', valueWasDefault=all_default, & + layoutParam=layoutMod, debuggingParam=debuggingMod) mesg = "! === module "//trim(modname)//" ===" call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0, & layoutParam=layoutMod, debuggingParam=debuggingMod) @@ -786,8 +812,10 @@ subroutine doc_module(doc, modname, desc, log_to_all, all_default, layoutMod, de repeat_doc = .false. if (present(layoutMod)) then ; if (layoutMod) repeat_doc = .true. ; endif if (present(debuggingMod)) then ; if (debuggingMod) repeat_doc = .true. ; endif - if (repeat_doc) & + if (repeat_doc) then + call writeMessageAndDesc(doc, '', '', valueWasDefault=all_default) call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0) + endif endif ; endif endif end subroutine doc_module diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 2f31d50607..7cf9df39f1 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -30,6 +30,7 @@ module MOM_domains use mpp_parameter_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE use mpp_parameter_mod, only : To_North => SUPDATE, To_South => NUPDATE, CENTER use fms_io_mod, only : file_exist, parse_mask_table +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get implicit none ; private @@ -45,6 +46,7 @@ module MOM_domains public :: start_group_pass, complete_group_pass public :: compute_block_extent, get_global_shape public :: get_simple_array_i_ind, get_simple_array_j_ind +public :: domain2D !> Do a halo update on an array interface pass_var @@ -1191,7 +1193,6 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & integer, dimension(4) :: global_indices !$ integer :: ocean_nthreads ! Number of Openmp threads !$ integer :: get_cpu_affinity, omp_get_thread_num, omp_get_num_threads -!$ integer :: omp_cores_per_node, adder, base_cpu !$ logical :: ocean_omp_hyper_thread integer :: nihalo_dflt, njhalo_dflt integer :: pe, proc_used @@ -1273,6 +1274,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & default=.false.) #ifndef NOT_SET_AFFINITY +!$ call fms_affinity_init !$OMP PARALLEL !$OMP master !$ ocean_nthreads = omp_get_num_threads() @@ -1284,27 +1286,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ default = 1, layoutParam=.true.) !$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & !$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) -!$ if (ocean_omp_hyper_thread) then -!$ call get_param(param_file, mdl, "OMP_CORES_PER_NODE", omp_cores_per_node, & -!$ "Number of cores per node needed for hyper-threading.", & -!$ fail_if_missing=.true., layoutParam=.true.) -!$ endif +!$ call fms_affinity_set('OCEAN', ocean_omp_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) -!$ base_cpu = get_cpu_affinity() -!$OMP PARALLEL private(adder) -!$ if (ocean_omp_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 -!$ else -!$ adder = omp_cores_per_node + omp_get_thread_num()/2 -!$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity(base_cpu + adder) -!!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() -!!$ call flush(6) -!$OMP END PARALLEL +!$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() +!$ call flush(6) !$ endif #endif call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", MOM_dom%symmetric, & diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index a07d828e5b..2e7a14dbe4 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1289,7 +1289,7 @@ end subroutine log_version_plain !> Log the name and value of an integer model parameter in documentation files. subroutine log_param_int(CS, modulename, varname, value, desc, units, & - default, layoutParam, debuggingParam) + default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the module using this parameter @@ -1303,6 +1303,8 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1315,13 +1317,13 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_int !> Log the name and values of an array of integer model parameter in documentation files. subroutine log_param_int_array(CS, modulename, varname, value, desc, & - units, default, layoutParam, debuggingParam) + units, default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the module using this parameter @@ -1335,6 +1337,8 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=1320) :: mesg character(len=240) :: myunits @@ -1348,13 +1352,13 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_int_array !> Log the name and value of a real model parameter in documentation files. subroutine log_param_real(CS, modulename, varname, value, desc, units, & - default, debuggingParam) + default, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1366,6 +1370,8 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1379,13 +1385,13 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real !> Log the name and values of an array of real model parameter in documentation files. subroutine log_param_real_array(CS, modulename, varname, value, desc, & - units, default, debuggingParam) + units, default, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1397,6 +1403,8 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=1320) :: mesg character(len=240) :: myunits @@ -1414,13 +1422,13 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real_array !> Log the name and value of a logical model parameter in documentation files. subroutine log_param_logical(CS, modulename, varname, value, desc, & - units, default, layoutParam, debuggingParam) + units, default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1434,6 +1442,8 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1450,13 +1460,13 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & myunits="Boolean"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_logical !> Log the name and value of a character string model parameter in documentation files. subroutine log_param_char(CS, modulename, varname, value, desc, units, & - default, layoutParam, debuggingParam) + default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1470,6 +1480,8 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1483,14 +1495,14 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_char !> This subroutine writes the value of a time-type parameter to a log file, !! along with its name and the module it came from. subroutine log_param_time(CS, modulename, varname, value, desc, units, & - default, timeunit, layoutParam, debuggingParam, log_date) + default, timeunit, layoutParam, debuggingParam, log_date, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1508,6 +1520,8 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. ! Local variables real :: real_time, real_default @@ -1543,10 +1557,10 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & default_string = convert_date_to_string(default) call doc_param(CS%doc, varname, desc, myunits, date_string, & default=default_string, layoutParam=layoutParam, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) else call doc_param(CS%doc, varname, desc, myunits, date_string, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) endif elseif (use_timeunit) then if (present(units)) then @@ -1566,12 +1580,12 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & real_default = (86400.0/timeunit)*days + secs/timeunit if (ticks > 0) real_default = real_default + & real(ticks) / (timeunit*get_ticks_per_second()) - call doc_param(CS%doc, varname, desc, myunits, real_time, real_default) + call doc_param(CS%doc, varname, desc, myunits, real_time, real_default, like_default=like_default) else - call doc_param(CS%doc, varname, desc, myunits, real_time) + call doc_param(CS%doc, varname, desc, myunits, real_time, like_default=like_default) endif else - call doc_param(CS%doc, varname, desc, value, default, units=units) + call doc_param(CS%doc, varname, desc, value, default, units=units, like_default=like_default) endif endif diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index c918f3a9ee..ed29b99b55 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1511,6 +1511,7 @@ subroutine restart_init(param_file, CS, restart_root) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_restart" ! This module's name. + logical :: all_default ! If true, all parameters are using their default values. if (associated(CS)) then call MOM_error(WARNING, "restart_init called with an associated control structure.") @@ -1518,10 +1519,25 @@ subroutine restart_init(param_file, CS, restart_root) endif allocate(CS) + ! Determine whether all paramters are set to their default values. + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "LARGE_FILE_SUPPORT", CS%large_file_support, & + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "MAX_FIELDS", CS%max_fields, default=100, do_not_log=.true.) + call get_param(param_file, mdl, "RESTART_CHECKSUMS_REQUIRED", CS%checksum_required, & + default=.true., do_not_log=.true.) + all_default = ((.not.CS%parallel_restartfiles) .and. (CS%large_file_support) .and. & + (CS%max_fields == 100) .and. (CS%checksum_required)) + if (.not.present(restart_root)) then + call get_param(param_file, mdl, "RESTARTFILE", CS%restartfile, & + default="MOM.res", do_not_log=.true.) + all_default = (all_default .and. (trim(CS%restartfile) == trim("MOM.res"))) + endif + ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", & - CS%parallel_restartfiles, & + call log_version(param_file, mdl, version, "", all_default=all_default) + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & "If true, each processor writes its own restart file, "//& "otherwise a single restart file is generated", & default=.false.) diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 7a2fb36608..1f0e001073 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -60,9 +60,10 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) ! Local variables integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = 'MOM_write_cputime' ! This module's name. + logical :: all_default ! If true, all parameters are using their default values. if (.not.associated(CS)) then allocate(CS) @@ -71,7 +72,13 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + + ! Determine whether all paramters are set to their default values. + call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, default=-1.0, do_not_log=.true.) + call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, default="CPU_stats", do_not_log=.true.) + all_default = (CS%maxcpu == -1.0) .and. (trim(CS%CPUfile) == trim("CPU_stats")) + + call log_version(param_file, mdl, version, "", all_default=all_default) call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, & "The maximum amount of cpu time per processor for which "//& "MOM should run before saving a restart file and "//& diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6b68cb3deb..66fd873f67 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -51,7 +51,6 @@ module MOM_ice_shelf use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init -use time_manager_mod, only : print_time implicit none ; private #include diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index be3ae1ecde..0c9fe4e77e 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1405,6 +1405,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after real :: h_face ! Thickness at a face for transport [Z ~> m] real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index b3e88697f2..a3784b5a34 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -12,7 +12,6 @@ module MOM_ice_shelf_state use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_get_input, only : directories, Get_MOM_input -use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync use MOM_coms, only : reproducing_sum use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 1ddf6f2345..b075da4141 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -249,7 +249,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) else max_depth = diagnoseMaximumDepth(D,G) call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth*Z_to_m, & - "The (diagnosed) maximum depth of the ocean.", units="m") + "The (diagnosed) maximum depth of the ocean.", units="m", like_default=.true.) endif if (trim(config) /= "DOME") then call limit_topography(D, G, PF, max_depth, US) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 33929737a7..a08d4883c8 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -4,12 +4,13 @@ module MOM_state_initialization ! This file is part of MOM6. See LICENSE.md for the license. use MOM_debugging, only : hchksum, qchksum, uvchksum +use MOM_density_integrals, only : int_specific_vol_dp +use MOM_density_integrals, only : find_depth_of_pressure_in_cell use MOM_coms, only : max_across_PEs, min_across_PEs, reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID -use MOM_EOS, only : find_depth_of_pressure_in_cell use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, read_param, log_param, param_file_type @@ -17,35 +18,30 @@ module MOM_state_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell use MOM_interface_heights, only : find_eta -use MOM_io, only : file_exists -use MOM_io, only : MOM_read_data, MOM_read_vector -use MOM_io, only : slasher -use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init +use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data +use MOM_open_boundary, only : set_tracer_data, initialize_segment_data use MOM_open_boundary, only : open_boundary_test_extern_h -use MOM_open_boundary, only : fill_temp_salt_segments +use MOM_open_boundary, only : fill_temp_salt_segments,setup_OBC_tracer_reservoirs use MOM_open_boundary, only : update_OBC_segment_data !use MOM_open_boundary, only : set_3D_OBC_data use MOM_grid_initialize, only : initialize_masks, set_grid_metrics use MOM_restart, only : restore_state, determine_is_new_run, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density use MOM_sponge, only : initialize_sponge, sponge_CS -use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge -use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge, ALE_sponge_CS use MOM_string_functions, only : uppercase, lowercase use MOM_time_manager, only : time_type use MOM_tracer_registry, only : tracer_registry_type use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : setVerticalGridAxes, verticalGrid_type -use MOM_ALE, only : pressure_gradient_plm use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain -use MOM_EOS, only : int_specific_vol_dp, convert_temp_salt_for_TEOS10 +use MOM_EOS, only : convert_temp_salt_for_TEOS10 use user_initialization, only : user_initialize_thickness, user_initialize_velocity -use user_initialization, only : user_init_temperature_salinity -use user_initialization, only : user_set_OBC_data +use user_initialization, only : user_init_temperature_salinity, user_set_OBC_data use user_initialization, only : user_initialize_sponges use DOME_initialization, only : DOME_initialize_thickness use DOME_initialization, only : DOME_set_OBC_data @@ -91,12 +87,12 @@ module MOM_state_initialization use MOM_tracer_Z_init, only : find_interfaces, tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated +use MOM_ALE, only : TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution use MOM_regridding, only : regridding_main use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer -use fms_io_mod, only : field_size implicit none ; private @@ -384,9 +380,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & end select endif endif ! not from_Z_file. - if (use_temperature .and. use_OBC) & + if (use_temperature .and. use_OBC) then call fill_temp_salt_segments(G, OBC, tv) - + call setup_OBC_tracer_reservoirs(G%ke, OBC) + endif ! The thicknesses in halo points might be needed to initialize the velocities. if (new_sim) call pass_var(h, G%Domain) @@ -562,6 +559,8 @@ 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 initialize_segment_data(G, OBC, PF) ! call initialize_segment_data(G, OBC, param_file) +! call open_boundary_config(G, US, PF, OBC) ! Call this once to fill boundary arrays from fixed values if (.not. OBC%needs_IO_for_data) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) @@ -970,7 +969,7 @@ subroutine convert_thickness(h, G, GV, US, tv) do itt=1,max_itt call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, 0.0, G%HI, & - tv%eqn_of_state, dz_geo) + tv%eqn_of_state, US, dz_geo) if (itt < max_itt) then ; do j=js,je call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, & tv%eqn_of_state, EOSdom) @@ -1149,7 +1148,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) ! Find edge values of T and S used in reconstructions if ( associated(ALE_CSp) ) then ! This should only be associated if we are in ALE mode - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) else ! call MOM_error(FATAL, "trim_for_ice: Does not work without ALE mode") do k=1,G%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -1218,7 +1217,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, do k=1,nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, & - P_b, z_out, z_tol=z_tol) + US, P_b, z_out, z_tol=z_tol) if (z_out>=e(K)) then ! Imposed pressure was less that pressure at top of cell exit @@ -2470,7 +2469,7 @@ subroutine MOM_state_init_tests(G, GV, US, tv) P_t = 0. do k = 1, nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), P_t, 0.5*P_tot, & - GV%Rho0, GV%g_Earth, tv%eqn_of_state, P_b, z_out) + GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out) write(0,*) k, US%RL2_T2_to_Pa*P_t, US%RL2_T2_to_Pa*P_b, 0.5*US%RL2_T2_to_Pa*P_tot, & US%Z_to_m*e(K), US%Z_to_m*e(K+1), US%Z_to_m*z_out P_t = P_b diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 6011ebb9f8..1a4c5bd011 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -7,6 +7,7 @@ module MOM_tracer_initialization_from_Z use MOM_coms, only : max_across_PEs, min_across_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP +use MOM_density_integrals, only : int_specific_vol_dp use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe @@ -24,7 +25,6 @@ module MOM_tracer_initialization_from_Z use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, setVerticalGridAxes use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type -use MOM_EOS, only : int_specific_vol_dp use MOM_ALE, only : ALE_remap_scalar implicit none ; private diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 089e1fc422..acc316cce4 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -1,9 +1,8 @@ !> Interfaces for MOM6 ensembles and data assimilation. module MOM_oda_driver_mod -! This file is part of MOM6. see LICENSE.md for the license. -use fms_mod, only : open_namelist_file, close_file, check_nml_error -use fms_mod, only : error_mesg, FATAL + ! This file is part of MOM6. see LICENSE.md for the license. + use mpp_mod, only : stdout, stdlog, mpp_error, npes=>mpp_npes,pe=>mpp_pe use mpp_mod, only : set_current_pelist => mpp_set_current_pelist use mpp_mod, only : set_root_pe => mpp_set_root_pe @@ -250,20 +249,6 @@ subroutine init_oda(Time, G, GV, CS) allocate(CS%tv%S(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%S(:,:,:)=0.0 call set_axes_info(CS%Grid, CS%GV, CS%US, PF, CS%diag_cs, set_vertical=.true.) - do n=1,CS%ensemble_size - write(fldnam,'(a,i2.2)') 'temp_prior_',n - CS%Ocean_prior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean potential temperature','degC') - write(fldnam,'(a,i2.2)') 'salt_prior_',n - CS%Ocean_prior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean salinity','psu') - write(fldnam,'(a,i2.2)') 'temp_posterior_',n - CS%Ocean_posterior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean potential temperature','degC') - write(fldnam,'(a,i2.2)') 'salt_posterior_',n - CS%Ocean_posterior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean salinity','psu') - enddo call mpp_get_data_domain(CS%mpp_domain,isd,ied,jsd,jed) allocate(CS%oda_grid) @@ -364,10 +349,6 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) CS%mpp_domain, CS%Ocean_prior%T(:,:,:,m), complete=.true.) call mpp_redistribute(CS%domains(m)%mpp_domain, S,& CS%mpp_domain, CS%Ocean_prior%S(:,:,:,m), complete=.true.) - if (CS%Ocean_prior%id_t(m)>0) & - used=send_data(CS%Ocean_prior%id_t(m), CS%Ocean_prior%T(isc:iec,jsc:jec,:,m), CS%Time) - if (CS%Ocean_prior%id_s(m)>0) & - used=send_data(CS%Ocean_prior%id_s(m), CS%Ocean_prior%S(isc:iec,jsc:jec,:,m), CS%Time) enddo deallocate(T,S) @@ -478,13 +459,13 @@ subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) allocate(CS%T(is:ie,js:je,nk,ens_size)) allocate(CS%S(is:ie,js:je,nk,ens_size)) allocate(CS%SSH(is:ie,js:je,ens_size)) - allocate(CS%id_t(ens_size));CS%id_t(:)=-1 - allocate(CS%id_s(ens_size));CS%id_s(:)=-1 +! allocate(CS%id_t(ens_size));CS%id_t(:)=-1 +! allocate(CS%id_s(ens_size));CS%id_s(:)=-1 ! allocate(CS%U(is:ie,js:je,nk,ens_size)) ! allocate(CS%V(is:ie,js:je,nk,ens_size)) ! allocate(CS%id_u(ens_size));CS%id_u(:)=-1 ! allocate(CS%id_v(ens_size));CS%id_v(:)=-1 - allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 +! allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 return end subroutine init_ocean_ensemble diff --git a/src/ocean_data_assim/core b/src/ocean_data_assim/core deleted file mode 120000 index e0a21d3192..0000000000 --- a/src/ocean_data_assim/core +++ /dev/null @@ -1 +0,0 @@ -../../pkg/MOM6_DA_hooks/src/core \ No newline at end of file diff --git a/src/ocean_data_assim/geoKdTree b/src/ocean_data_assim/geoKdTree deleted file mode 120000 index 61fd167bb6..0000000000 --- a/src/ocean_data_assim/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -../../pkg/geoKdTree \ No newline at end of file diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 7c1405308f..4e9897f6eb 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -19,6 +19,7 @@ module MOM_hor_visc 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_variables, only : accel_diag_ptrs implicit none ; private @@ -174,9 +175,16 @@ module MOM_hor_visc type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics + ! real, pointer :: hf_diffu(:,:,:) => NULL() ! Zonal hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, pointer :: hf_diffv(:,:,:) => NULL() ! Merdional hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !>@{ !! Diagnostic id integer :: id_diffu = -1, id_diffv = -1 + ! integer :: id_hf_diffu = -1, id_hf_diffv = -1 + integer :: id_hf_diffu_2d = -1, id_hf_diffv_2d = -1 integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 @@ -203,7 +211,7 @@ module MOM_hor_visc !! 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, US, & - CS, OBC, BT, TD) + CS, OBC, BT, TD, ADp) 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)), & @@ -230,6 +238,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! barotropic velocities. type(thickness_diffuse_CS), optional, pointer :: TD !< Pointer to a structure containing !! thickness diffusivities. + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers + ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & Del2u, & ! The u-compontent of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] @@ -263,6 +273,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] + real, allocatable, dimension(:,:) :: hf_diffu_2d ! Depth sum of hf_diffu [L T-2 ~> m s-2] + real, allocatable, dimension(:,:) :: hf_diffv_2d ! Depth sum of hf_diffv [L T-2 ~> m s-2] + real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] @@ -1307,12 +1320,47 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call post_data(CS%id_FrictWorkIntz, FrictWorkIntz, CS%diag) endif + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (present(ADp) .and. (CS%id_hf_diffu > 0)) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_diffu(I,j,k) = diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_diffu, CS%hf_diffu, CS%diag) + !endif + !if (present(ADp) .and. (CS%id_hf_diffv > 0)) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_diffv(i,J,k) = diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_diffv, CS%hf_diffv, CS%diag) + !endif + if (present(ADp) .and. (CS%id_hf_diffu_2d > 0)) then + allocate(hf_diffu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_diffu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_diffu_2d(I,j) = hf_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffu_2d, hf_diffu_2d, CS%diag) + deallocate(hf_diffu_2d) + endif + if (present(ADp) .and. (CS%id_hf_diffv_2d > 0)) then + allocate(hf_diffv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_diffv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_diffv_2d(i,J) = hf_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffv_2d, hf_diffv_2d, CS%diag) + deallocate(hf_diffv_2d) + endif + 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, US, param_file, diag, CS, MEKE) +subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) 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 @@ -1321,6 +1369,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. type(hor_visc_CS), pointer :: CS !< Pointer to the control structure for this module type(MEKE_type), pointer :: MEKE !< MEKE data + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v @@ -2016,6 +2065,36 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%id_diffv = register_diag_field('ocean_model', 'diffv', diag%axesCvL, Time, & 'Meridional Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_diffu = register_diag_field('ocean_model', 'hf_diffu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if ((CS%id_hf_diffu > 0) .and. (present(ADp))) then + ! call safe_alloc_ptr(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + !endif + + !CS%id_hf_diffv = register_diag_field('ocean_model', 'hf_diffv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if ((CS%id_hf_diffv > 0) .and. (present(ADp))) then + ! call safe_alloc_ptr(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + !endif + + CS%id_hf_diffu_2d = register_diag_field('ocean_model', 'hf_diffu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffu_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + endif + + CS%id_hf_diffv_2d = register_diag_field('ocean_model', 'hf_diffv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffv_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + endif + if (CS%biharmonic) then CS%id_Ah_h = register_diag_field('ocean_model', 'Ahh', diag%axesTL, Time, & 'Biharmonic Horizontal Viscosity at h Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T, & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 0f07701eda..9a0a994450 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -3,20 +3,21 @@ module MOM_lateral_mixing_coeffs ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : hchksum, uvchksum -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg -use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data -use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled -use MOM_domains, only : create_group_pass, do_group_pass -use MOM_domains, only : group_pass_type, pass_var, pass_vector -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data +use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled +use MOM_domains, only : create_group_pass, do_group_pass +use MOM_domains, only : group_pass_type, pass_var, pass_vector +use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_interface_heights, only : find_eta -use MOM_isopycnal_slopes, only : calc_isoneutral_slopes -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_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init +use MOM_isopycnal_slopes, only : calc_isoneutral_slopes +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_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE implicit none ; private @@ -432,7 +433,7 @@ end subroutine calc_resoln_function !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity -subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) +subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -440,6 +441,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, intent(in) :: dt !< Time increment [T ~> s] type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & e ! The interface heights relative to mean sea level [Z ~> m]. @@ -453,12 +455,12 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_stored_slopes) then call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & - CS%slope_x, CS%slope_y, N2_u, N2_v, 1) - call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) + CS%slope_x, CS%slope_y, N2_u, N2_v, 1, OBC=OBC) + call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) ! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) else !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true.) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true., OBC=OBC) endif endif @@ -476,7 +478,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) end subroutine calc_slope_functions !> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al. -subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) +subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] @@ -488,6 +490,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) !! at v-points [T-2 ~> s-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: S2 ! Interface slope squared [nondim] @@ -496,10 +499,12 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. integer :: is, ie, js, je, nz integer :: i, j, k, kb_max + integer :: l_seg real :: S2max, wNE, wSE, wSW, wNW real :: H_u(SZIB_(G)), H_v(SZI_(G)) real :: S2_u(SZIB_(G), SZJ_(G)) real :: S2_v(SZI_(G), SZJB_(G)) + logical :: local_open_u_BC, local_open_v_BC if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") @@ -511,6 +516,13 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + S2max = CS%Visbeck_S_max**2 !$OMP parallel do default(shared) @@ -556,6 +568,15 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) else CS%SN_u(I,j) = 0. endif + if (local_open_u_BC) then + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + CS%SN_u(i,J) = 0. + endif + endif + endif enddo enddo @@ -592,6 +613,15 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) else CS%SN_v(i,J) = 0. endif + if (local_open_v_BC) then + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%open) then + CS%SN_v(i,J) = 0. + endif + endif + endif enddo enddo @@ -613,7 +643,7 @@ end subroutine calc_Visbeck_coeffs !> The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. -subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes) +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -622,6 +652,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface position [Z ~> m] logical, intent(in) :: calculate_slopes !< If true, calculate slopes internally !! otherwise use slopes stored in CS + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: E_x(SZIB_(G), SZJ_(G)) ! X-slope of interface at u points [nondim] (for diagnostics) real :: E_y(SZI_(G), SZJB_(G)) ! Y-slope of interface at v points [nondim] (for diagnostics) @@ -635,8 +666,10 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real :: one_meter ! One meter in thickness units [H ~> m or kg m-2]. integer :: is, ie, js, je, nz integer :: i, j, k, kb_max + integer :: l_seg real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(G)) real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(G)) + logical :: local_open_u_BC, local_open_v_BC if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") @@ -648,6 +681,13 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + one_meter = 1.0 * GV%m_to_H h_neglect = GV%H_subroundoff H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) @@ -723,6 +763,15 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop else CS%SN_u(I,j) = 0.0 endif + if (local_open_u_BC) then + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + CS%SN_u(I,j) = 0. + endif + endif + endif enddo enddo !$OMP parallel do default(shared) @@ -740,6 +789,15 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop else CS%SN_v(I,j) = 0.0 endif + if (local_open_v_BC) then + l_seg = OBC%segnum_v(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(I,j))%open) then + CS%SN_v(I,j) = 0. + endif + endif + endif enddo enddo diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 7d5fc8b846..b59ab34c91 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -10,6 +10,7 @@ module MOM_thickness_diffuse use MOM_domains, only : pass_var, CORNER, pass_vector use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density_second_derivs use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta @@ -19,7 +20,6 @@ module MOM_thickness_diffuse use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, cont_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type - implicit none ; private #include @@ -77,6 +77,10 @@ module MOM_thickness_diffuse !! than the streamfunction for the GM source term. logical :: use_GM_work_bug !< If true, use the incorrect sign for the !! top-level work tendency on the top layer. + real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean + !! temperature gradient in the deterministic part of the Stanley parameterization. + !! Negative values disable the scheme." [nondim] + type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] real, pointer :: diagSlopeX(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] @@ -599,10 +603,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1] - drho_dS_u ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dS_u, & ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_dT_u ! The second derivative of density with temperature at u points [R degC-2 ~> kg m-3 degC-2] + real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ingored. real, dimension(SZI_(G)) :: & drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1] - drho_dS_v ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dS_v, & ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_dT_v ! The second derivative of density with temperature at v points [R degC-2 ~> kg m-3 degC-2] real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & @@ -668,6 +675,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] + real :: dTdi2, dTdj2 ! pot. temp. differences, squared. + real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: Tsgs2 ! Sub-grid temperature variance [degC2] + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: diag_sfn_y, diag_sfn_unlim_y ! Diagnostics logical :: present_int_slope_u, present_int_slope_v @@ -676,7 +686,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! state calculations at u-points. integer, dimension(2) :: EOSdom_v ! The shifted I-computational domain to use for equation of ! state calculations at v-points. - integer :: is, ie, js, je, nz, IsdB + logical :: use_Stanley + integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB @@ -694,6 +705,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV present_int_slope_v = PRESENT(int_slope_v) present_slope_x = PRESENT(slope_x) present_slope_y = PRESENT(slope_y) + use_Stanley = CS%Stanley_det_coeff >= 0. nk_linear = max(GV%nkml, 1) @@ -707,15 +719,18 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV find_work = (associated(CS%GMwork) .or. find_work) if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, 1, larger_h_denom=.true.) + halo = 1 ! Default halo to fill is 1 + if (use_Stanley) halo = 2 ! Need wider valid halo for gradients of T + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo, larger_h_denom=.true.) endif if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & "cg1 must be associated when using FGNV streamfunction.") -!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, & -!$OMP G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v, & -!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) +!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, use_Stanley, & +!$OMP CS,G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v,Tsgs2,T, & +!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) & +!$OMP private(dTdi2,dTdj2) ! Find the maximum and minimum permitted streamfunction. !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 @@ -728,6 +743,20 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_frac(i,j,1) = 1.0 pres(i,j,2) = pres(i,j,1) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,1) enddo ; enddo + if (use_Stanley) then +!$OMP do + do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + ! SGS variance in i-direction [degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 + Tsgs2(i,j,k) = CS%Stanley_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + enddo ; enddo ; enddo + endif !$OMP do do j=js-1,je+1 do k=2,nz ; do i=is-1,ie+1 @@ -759,9 +788,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$OMP int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & !$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1, & !$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor,EOSdom_u, & +!$OMP use_stanley, Tsgs2, & !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & +!$OMP drho_dT_dT_u,scrap, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & !$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & @@ -775,7 +806,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn) + (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn .or. use_Stanley) ! Calculate the zonal fluxes and gradients. if (calc_derivatives) then @@ -787,6 +818,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & tv%eqn_of_state, EOSdom_u) endif + if (use_Stanley) then + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_u, S_u, pres_u, & + scrap, scrap, drho_dT_dT_u, scrap, scrap, & + (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) + endif do I=is-1,ie if (calc_derivatives) then @@ -805,7 +843,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV elseif (find_work) then ! This is used in pure stacked SW mode drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K) endif - + if (use_Stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdiA = drdiA + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k-1)-Tsgs2(i,j,k-1) ) + drdiB = drdiB + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k)-Tsgs2(i,j,k) ) + endif if (find_work) drdi_u(I,k) = drdiB if (k > nk_linear) then @@ -1013,9 +1056,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$OMP int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & !$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1, & !$OMP diag_sfn_y,diag_sfn_unlim_y,N2_floor,EOSdom_v,& +!$OMP use_stanley, Tsgs2, & !$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & +!$OMP drho_dT_dT_v,scrap, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & !$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & @@ -1028,7 +1073,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_y) + (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn .or. use_Stanley) if (calc_derivatives) then do i=is,ie @@ -1039,6 +1084,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & tv%eqn_of_state, EOSdom_v) endif + if (use_Stanley) then + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_v, S_v, pres_v, & + scrap, scrap, drho_dT_dT_v, scrap, scrap, & + is, ie-is+1, tv%eqn_of_state) + endif do i=is,ie if (calc_derivatives) then ! Estimate the horizontal density gradients along layers. @@ -1056,6 +1108,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV elseif (find_work) then ! This is used in pure stacked SW mode drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K) endif + if (use_Stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdjA = drdjA + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k-1)-Tsgs2(i,j,k-1) ) + drdjB = drdjB + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k)-Tsgs2(i,j,k) ) + endif if (find_work) drdj_v(i,k) = drdjB @@ -1887,6 +1945,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "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, "STANLEY_PRM_DET_COEFF", CS%Stanley_det_coeff, & + "The coefficient correlating SGS temperature variance with the mean "//& + "temperature gradient in the deterministic part of the Stanley parameterization. "//& + "Negative values disable the scheme.", units="nondim", default=-1.0) call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s, do_not_log=.not.CS%use_FGNV_streamfn) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 5088a92d6e..27aa43274b 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -256,7 +256,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ answers_2018=CS%remap_answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & - "The total number of columns where sponges are applied at h points.") + "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then @@ -300,7 +300,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ total_sponge_cols_u = CS%num_col_u call sum_across_PEs(total_sponge_cols_u) call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") + "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 @@ -336,7 +336,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ total_sponge_cols_v = CS%num_col_v call sum_across_PEs(total_sponge_cols_v) call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + "The total number of columns where sponges are applied at v points.", like_default=.true.) endif end subroutine initialize_ALE_sponge_fixed @@ -484,7 +484,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & answers_2018=CS%remap_answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & - "The total number of columns where sponges are applied at h points.") + "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)) ; Iresttime_u(:,:) = 0.0 allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)) ; Iresttime_v(:,:) = 0.0 @@ -513,7 +513,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) total_sponge_cols_u = CS%num_col_u call sum_across_PEs(total_sponge_cols_u) call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") + "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec @@ -538,7 +538,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) total_sponge_cols_v = CS%num_col_v call sum_across_PEs(total_sponge_cols_v) call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + "The total number of columns where sponges are applied at v points.", like_default=.true.) endif end subroutine initialize_ALE_sponge_varying diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index f9115b1041..e0889360b9 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -627,7 +627,6 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & real :: LangEnhK ! Langmuir enhancement for mixing coefficient -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0, scale=US%Z_to_m*US%s_to_T) @@ -635,7 +634,6 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) endif -#endif nonLocalTrans(:,:) = 0.0 @@ -862,12 +860,10 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & enddo ! j -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) endif -#endif ! send diagnostics to post_data if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) @@ -952,14 +948,12 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: WST -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) call hchksum(u, "KPP in: u",G%HI,haloshift=0) call hchksum(v, "KPP in: v",G%HI,haloshift=0) endif -#endif ! some constants GoRho = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / GV%Rho0 diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 91085047c9..713282cdb3 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -195,14 +195,14 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) endif hc = (tv%C_p*GV%H_to_RZ) * h(i,j,k) - if (h(i,j,k) <= 10.0*GV%Angstrom_H) then + if (h(i,j,k) <= 10.0*(GV%Angstrom_H + GV%H_subroundoff)) then ! Very thin layers should not be cooled by the frazil flux. if (tv%T(i,j,k) < T_freeze(i)) then fraz_col(i) = fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) tv%T(i,j,k) = T_freeze(i) endif - else - if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) <= 0.0) then + elseif ((fraz_col(i) > 0.0) .or. (tv%T(i,j,k) < T_freeze(i))) then + if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) < 0.0) then tv%T(i,j,k) = tv%T(i,j,k) - fraz_col(i) / hc fraz_col(i) = 0.0 else @@ -822,19 +822,18 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - ! Only apply forcing if fluxes%sw is associated. - if (.not.associated(fluxes%sw)) return - -#define _OLD_ALG_ Idt = 1.0 / dt calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 + if (present(cTKE)) cTKE(:,:,:) = 0.0 g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ EOSdom(:) = EOS_domain(G%HI) - if (present(cTKE)) cTKE(:,:,:) = 0.0 + ! Only apply forcing if fluxes%sw is associated. + if (.not.associated(fluxes%sw) .and. .not.calculate_energetics) return + if (calculate_buoyancy) then SurfPressure(:) = 0.0 GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 @@ -874,7 +873,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t h2d(i,k) = h(i,j,k) T2d(i,k) = tv%T(i,j,k) enddo ; enddo - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) if (calculate_energetics) then ! The partial derivatives of specific volume with temperature and @@ -898,6 +896,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t pen_TKE_2d(:,:) = 0.0 endif + ! Nothing more is done on this j-slice if there is no buoyancy forcing. + if (.not.associated(fluxes%sw)) cycle + + if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) + ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: ! netMassInOut = surface water fluxes [H ~> m or kg m-2] over time step diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 32c2797394..5a9e67bfd9 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2339,9 +2339,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Logging parameters ! 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*US%s_to_T, & + call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m*US%s_to_T, & "The (tiny) minimum friction velocity used within the "//& - "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1") + "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1", & + like_default=.true.) !/ Checking output flags diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 1783955d53..3be6628b14 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -408,7 +408,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h else do i=is,ie ; pres(i) = 0.0 ; enddo endif - EOSdom(:) = EOS_domain(G%HI) + EOSdom(:) = EOS_domain(G%HI, halo) call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), tv%eqn_of_state, EOSdom) do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) ; enddo do K=2,nz diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 7db9be0018..04e67f0be5 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -19,9 +19,6 @@ module MOM_kappa_shear implicit none ; private #include -#ifdef use_netCDF -#include -#endif public Calculate_kappa_shear, Calc_kappa_shear_vertex, kappa_shear_init public kappa_shear_is_used, kappa_shear_at_vertex @@ -99,9 +96,6 @@ module MOM_kappa_shear ! integer :: id_clock_project, id_clock_KQ, id_clock_avg, id_clock_setup -#undef DEBUG -#undef ADD_DIAGNOSTICS - contains !> Subroutine for calculating shear-driven diffusivity and TKE in tracer columns @@ -177,15 +171,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! interpolating back to the original index space [nondim]. integer :: is, ie, js, je, i, j, k, nz, nzc - ! Diagnostics that should be deleted? -#ifdef ADD_DIAGNOSTICS - real, dimension(SZK_(GV)+1) :: & ! Additional diagnostics. - I_Ld2_1d, dz_Int_1d - real, dimension(SZI_(G),SZK_(GV)+1) :: & ! 2-D versions of diagnostics. - I_Ld2_2d, dz_Int_2d - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ! 3-D versions of diagnostics. - I_Ld2_3d, dz_Int_3d -#endif is = G%isc ; ie = G%iec; js = G%jsc ; je = G%jec ; nz = GV%ke use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. @@ -195,9 +180,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & dz_massless = 0.1*sqrt(k0dt) !$OMP parallel do default(private) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,new_kappa, & -#ifdef ADD_DIAGNOSTICS - !$OMP I_Ld2_3d,dz_Int_3d, & -#endif !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) do j=js,je do k=1,nz ; do i=is,ie @@ -295,15 +277,9 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & do K=1,nzc+1 ; kappa(K) = kappa_2d(i,K) ; enddo endif -#ifdef ADD_DIAGNOSTICS - call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US, I_Ld2_1d, dz_Int_1d) -#else call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) -#endif ! call cpu_clock_begin(id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. @@ -329,18 +305,10 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif enddo endif -#ifdef ADD_DIAGNOSTICS - do K=1,nz+1 - I_Ld2_2d(i,K) = I_Ld2_1d(K) ; dz_Int_2d(i,K) = dz_Int_1d(K) - enddo -#endif ! call cpu_clock_end(id_clock_setup) else ! Land points, still inside the i-loop. do K=1,nz+1 kappa_2d(i,K) = 0.0 ; tke_2d(i,K) = 0.0 -#ifdef ADD_DIAGNOSTICS - I_Ld2_2d(i,K) = 0.0 ; dz_Int_2d(i,K) = 0.0 -#endif enddo endif ; enddo ! i-loop @@ -348,9 +316,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kappa_io(i,j,K) = G%mask2dT(i,j) * kappa_2d(i,K) tke_io(i,j,K) = G%mask2dT(i,j) * tke_2d(i,K) kv_io(i,j,K) = ( G%mask2dT(i,j) * kappa_2d(i,K) ) * CS%Prandtl_turb -#ifdef ADD_DIAGNOSTICS - I_Ld2_3d(i,j,K) = I_Ld2_2d(i,K) ; dz_Int_3d(i,j,K) = dz_Int_2d(i,K) -#endif enddo ; enddo enddo ! end of j-loop @@ -362,10 +327,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) -#ifdef ADD_DIAGNOSTICS - if (CS%id_ILd2 > 0) call post_data(CS%id_ILd2, I_Ld2_3d, CS%diag) - if (CS%id_dz_Int > 0) call post_data(CS%id_dz_Int, dz_Int_3d, CS%diag) -#endif end subroutine Calculate_kappa_shear @@ -435,8 +396,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. real :: dz_massless ! A layer thickness that is considered massless [Z ~> m]. - real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. - real :: I_Prandtl + real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. + real :: I_Prandtl ! The inverse of the turbulent Prandtl number [nondim]. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. logical :: new_kappa = .true. ! If true, ignore the value of kappa from the @@ -451,14 +412,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ integer :: IsB, IeB, JsB, JeB, i, j, k, nz, nzc, J2, J2m1 ! Diagnostics that should be deleted? -#ifdef ADD_DIAGNOSTICS - real, dimension(SZK_(GV)+1) :: & ! Additional diagnostics. - I_Ld2_1d, dz_Int_1d - real, dimension(SZI_(G),SZK_(GV)+1) :: & ! 2-D versions of diagnostics. - I_Ld2_2d, dz_Int_2d - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ! 3-D versions of diagnostics. - I_Ld2_3d, dz_Int_3d -#endif isB = G%isc-1 ; ieB = G%iecB ; jsB = G%jsc-1 ; jeB = G%jecB ; nz = GV%ke use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. @@ -469,10 +422,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,new_kappa, & -#ifdef ADD_DIAGNOSTICS - !$OMP I_Ld2_3d,dz_Int_3d, & -#endif - !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) + !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io,I_Prandtl) do J=JsB,JeB J2 = mod(J,2)+1 ; J2m1 = 3-J2 ! = mod(J-1,2)+1 @@ -597,15 +547,9 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do K=1,nzc+1 ; kappa(K) = kappa_2d(I,K,J2) ; enddo endif -#ifdef ADD_DIAGNOSTICS - call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US, I_Ld2_1d, dz_Int_1d) -#else call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) -#endif ! call cpu_clock_begin(Id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. if (nz == nzc) then @@ -628,27 +572,16 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ endif enddo endif -#ifdef ADD_DIAGNOSTICS - do K=1,nz+1 - I_Ld2_2d(i,K) = I_Ld2_1d(K) ; dz_Int_2d(i,K) = dz_Int_1d(K) - enddo -#endif ! call cpu_clock_end(Id_clock_setup) else ! Land points, still inside the i-loop. do K=1,nz+1 kappa_2d(I,K,J2) = 0.0 ; tke_2d(I,K) = 0.0 -#ifdef ADD_DIAGNOSTICS - I_Ld2_2d(I,K) = 0.0 ; dz_Int_2d(I,K) = 0.0 -#endif enddo endif ; enddo ! i-loop do K=1,nz+1 ; do I=IsB,IeB tke_io(I,J,K) = G%mask2dBu(I,J) * tke_2d(I,K) kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_2d(I,K,J2) ) * CS%Prandtl_turb -#ifdef ADD_DIAGNOSTICS - I_Ld2_3d(I,J,K) = I_Ld2_2d(I,K) ; dz_Int_3d(I,J,K) = dz_Int_2d(I,K) -#endif enddo ; enddo if (J>=G%jsc) then ; do K=1,nz+1 ; do i=G%isc,G%iec ! Set the diffusivities in tracer columns from the values at vertices. @@ -666,10 +599,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) -#ifdef ADD_DIAGNOSTICS - if (CS%id_ILd2 > 0) call post_data(CS%id_ILd2, I_Ld2_3d, CS%diag) - if (CS%id_dz_Int > 0) call post_data(CS%id_dz_Int, dz_Int_3d, CS%diag) -#endif end subroutine Calc_kappa_shear_vertex @@ -794,23 +723,10 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! to estimate the maximum permitted time step. I.e., ! the resolution is 1/2^dt_refinements. integer :: k, itt, itt_dt -#ifdef DEBUG - integer :: max_debug_itt ; parameter(max_debug_itt=20) - real :: wt(SZK_(GV)+1), wt_tot, I_wt_tot, wt_itt - real, dimension(SZK_(GV)+1) :: & - Ri_k, tke_prev, dtke, dkappa, dtke_norm, & - N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] - ksrc_av ! The average through the iterations of k_src [T-1 ~> s-1]. - real, dimension(SZK_(GV)+1,0:max_debug_itt) :: & - tke_it1, N2_it1, Sh2_it1, ksrc_it1, kappa_it1, kprev_it1 - real, dimension(SZK_(GV)+1,1:max_debug_itt) :: & - dkappa_it1, wt_it1, K_Q_it1, d_dkappa_it1, dkappa_norm - real, dimension(SZK_(GV),0:max_debug_itt) :: & - u_it1, v_it1, rho_it1, T_it1, S_it1 - real, dimension(0:max_debug_itt) :: & - dk_wt_it1, dkpos_wt_it1, dkneg_wt_it1, k_mag - real, dimension(max_debug_itt) :: dt_it1 -#endif + + ! This calculation of N2 is for debugging only. + ! real, dimension(SZK_(GV)+1) :: & + ! N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] Ri_crit = CS%Rino_crit gR0 = GV%Rho0 * GV%g_Earth @@ -916,45 +832,12 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo endif -#ifdef DEBUG - N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 - do K=2,nzc - N2_debug(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & - dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & - I_dz_int(K), 0.0) - enddo - do k=1,nzc - u_it1(k,0) = u0xdz(k)*Idz(k) ; v_it1(k,0) = v0xdz(k)*Idz(k) - T_it1(k,0) = T0xdz(k)*Idz(k) ; S_it1(k,0) = S0xdz(k)*Idz(k) - enddo - do K=1,nzc+1 - kprev_it1(K,0) = kappa(K) ; kappa_it1(K,0) = kappa(K) - tke_it1(K,0) = 0.0 - N2_it1(K,0) = N2_debug(K) ; Sh2_it1(K,0) = S2(K) ; ksrc_it1(K,0) = K_src(K) - enddo - do k=nzc+1,GV%ke - u_it1(k,0) = 0.0 ; v_it1(k,0) = 0.0 - T_it1(k,0) = 0.0 ; S_it1(k,0) = 0.0 - kprev_it1(K+1,0) = 0.0 ; kappa_it1(K+1,0) = 0.0 ; tke_it1(K+1,0) = 0.0 - N2_it1(K+1,0) = 0.0 ; Sh2_it1(K+1,0) = 0.0 ; ksrc_it1(K+1,0) = 0.0 - enddo - do itt=1,max_debug_itt - dt_it1(itt) = 0.0 - do k=1,GV%ke - u_it1(k,itt) = 0.0 ; v_it1(k,itt) = 0.0 - T_it1(k,itt) = 0.0 ; S_it1(k,itt) = 0.0 - rho_it1(k,itt) = 0.0 - enddo - do K=1,GV%ke+1 - kprev_it1(K,itt) = 0.0 ; kappa_it1(K,itt) = 0.0 ; tke_it1(K,itt) = 0.0 - N2_it1(K,itt) = 0.0 ; Sh2_it1(K,itt) = 0.0 - ksrc_it1(K,itt) = 0.0 - dkappa_it1(K,itt) = 0.0 ; wt_it1(K,itt) = 0.0 - K_Q_it1(K,itt) = 0.0 ; d_dkappa_it1(K,itt) = 0.0 - enddo - enddo - do K=1,GV%ke+1 ; ksrc_av(K) = 0.0 ; enddo -#endif + ! N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 + ! do K=2,nzc + ! N2_debug(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & + ! dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & + ! I_dz_int(K), 0.0) + ! enddo ! This call just calculates N2 and S2. call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, dz, I_dz_int, & @@ -981,12 +864,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! ---------------------------------------------------- ! Calculate new values of u, v, rho, N^2 and S. ! ---------------------------------------------------- -#ifdef DEBUG - do K=1,nzc+1 - Ri_k(K) = 1e3 ; if (S2(K) > 1e-3*N2(K)) Ri_k(K) = N2(K) / S2(K) - if (itt > 1) then ; tke_prev(K) = tke(K) ; else ; tke_prev(K) = 0.0 ; endif - enddo -#endif ! call cpu_clock_begin(id_clock_KQ) call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & @@ -1099,9 +976,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! This would be here but does nothing. ! kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt tke_avg(K) = tke_avg(K) + dt_wt*tke(K) -#ifdef DEBUG - tke_pred(K) = tke(K) ; kappa_pred(K) = 0.0 ; kappa(K) = 0.0 -#endif enddo ! call cpu_clock_end(id_clock_avg) else @@ -1157,63 +1031,10 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! call cpu_clock_end(id_clock_project) endif -#ifdef DEBUG - if (itt <= max_debug_itt) then - dt_it1(itt) = dt_now - dk_wt_it1(itt) = 0.0 ; dkpos_wt_it1(itt) = 0.0 ; dkneg_wt_it1(itt) = 0.0 - k_mag(itt) = 0.0 - wt_itt = 1.0/real(itt) ; wt_tot = 0.0 - do K=1,nzc+1 - ksrc_av(K) = (1.0-wt_itt)*ksrc_av(K) + wt_itt*K_src(K) - wt_tot = wt_tot + dz_Int(K) * ksrc_av(K) - enddo - ! Use the 1/0=0 convention. - I_wt_tot = 0.0 ; if (wt_tot > 0.0) I_wt_tot = 1.0/wt_tot - - do K=1,nzc+1 - wt(K) = (dz_Int(K)*ksrc_av(K)) * I_wt_tot - k_mag(itt) = k_mag(itt) + wt(K)*kappa_mid(K) - dkappa_it1(K,itt) = kappa_pred(K) - kappa_out(K) - dk_wt_it1(itt) = dk_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - if (dkappa_it1(K,itt) > 0.0) then - dkpos_wt_it1(itt) = dkpos_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - else - dkneg_wt_it1(itt) = dkneg_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - endif - wt_it1(K,itt) = wt(K) - enddo - endif - do K=1,nzc+1 - Ri_k(K) = 1e3 ; if (N2(K) < 1e3 * S2(K)) Ri_k(K) = N2(K) / S2(K) - dtke(K) = tke_pred(K) - tke(K) - dtke_norm(K) = dtke(K) / (0.5*(tke(K) + tke_pred(K))) - dkappa(K) = kappa_pred(K) - kappa_out(K) - enddo - if (itt <= max_debug_itt) then - do k=1,nzc - u_it1(k,itt) = u(k) ; v_it1(k,itt) = v(k) - T_it1(k,itt) = T(k) ; S_it1(k,itt) = Sal(k) - enddo - do K=1,nzc+1 - kprev_it1(K,itt) = kappa_out(K) - kappa_it1(K,itt) = kappa_mid(K) ; tke_it1(K,itt) = 0.5*(tke(K)+tke_pred(K)) - N2_it1(K,itt)=N2(K) ; Sh2_it1(K,itt)=S2(K) - ksrc_it1(K,itt) = kappa_src(K) - K_Q_it1(K,itt) = kappa_out(K) / (TKE(K)) - if (itt > 1) then - if (abs(dkappa_it1(K,itt-1)) > 1e-20) & - d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) - endif - dkappa_norm(K,itt) = dkappa(K) / max(0.5*(kappa_pred(K) + kappa_out(K)), US%m2_s_to_Z2_T*1e-100) - enddo - endif -#endif - if (dt_rem <= 0.0) exit enddo ! end itt loop -#ifdef ADD_DIAGNOSTICS if (present(I_Ld2_1d)) then do K=1,GV%ke+1 ; I_Ld2_1d(K) = 0.0 ; enddo do K=2,nzc ; if (TKE(K) > 0.0) & @@ -1224,7 +1045,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & do K=1,nzc+1 ; dz_Int_1d(K) = dz_Int(K) ; enddo do K=nzc+2,GV%ke ; dz_Int_1d(K) = 0.0 ; enddo endif -#endif end subroutine kappa_shear_column @@ -1474,18 +1294,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & integer :: ks_kappa, ke_kappa, ke_tke ! The ranges of k-indices that are or integer :: ks_kappa_prev, ke_kappa_prev ! were being worked on. integer :: itt, k, k2 -#ifdef DEBUG - integer :: max_debug_itt ; parameter(max_debug_itt=20) + + ! These variables are used only for debugging. + logical, parameter :: debug_soln = .false. real :: K_err_lin, Q_err_lin, TKE_src_norm real, dimension(nz+1) :: & I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [Z-2 ~> m-2]. kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 T-1 ~> m2 s-1]. TKE_prev ! The value of TKE at the start of the current iteration [Z2 T-2 ~> m2 s-2]. - real, dimension(nz+1,1:max_debug_itt) :: & - tke_it1, kappa_it1, kprev_it1, & ! Various values from each iteration. - dkappa_it1, K_Q_it1, d_dkappa_it1, dkappa_norm_it1 - integer :: it2 -#endif c_N2 = CS%C_N**2 ; c_S2 = CS%C_S**2 q0 = CS%TKE_bg ; kappa0 = CS%kappa_0 @@ -1529,7 +1345,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! TKE_decay(K) = c_n*sqrt(N2(K)) + c_s*sqrt(S2(K)) ! The expression in JHL. TKE_decay(K) = sqrt(c_n2*N2(K) + c_s2*S2(K)) if ((kappa(K) > 0.0) .and. (K_Q(K) > 0.0)) then - TKE(K) = kappa(K) / K_Q(K) + TKE(K) = kappa(K) / K_Q(K) ! Perhaps take the max with TKE_min else TKE(K) = TKE_min endif @@ -1564,9 +1380,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Calculate TKE ! ---------------------------------------------------- -#ifdef DEBUG - do K=1,nz+1 ; kappa_prev(K) = kappa(K) ; TKE_prev(K) = TKE(K) ; enddo -#endif + if (debug_soln) then ; do K=1,nz+1 ; kappa_prev(K) = kappa(K) ; TKE_prev(K) = TKE(K) ; enddo ; endif if (.not.do_Newton) then ! Use separate steps of the TKE and kappa equations, that are @@ -1792,25 +1606,20 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dQ(ke_kappa+1) = dQ(ke_kappa+1) / (1.0 - cQ(ke_kappa+2)*e1(ke_kappa+2)) TKE(ke_kappa+1) = max(TKE(ke_kappa+1) + dQ(ke_kappa+1), TKE_min) do k=ke_kappa+2,nz+1 -#ifdef DEBUG - if (K < nz+1) then + if (debug_soln .and. (K < nz+1)) then ! Ignore this source? aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) - tke_src_norm = (dz_Int(K) * (kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & - (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & - (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) + ! tke_src_norm = (dz_Int(K) * (kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & + ! (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & + ! (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) endif -#endif dK(K) = 0.0 ! Ensure that TKE+dQ will not drop below 0.5*TKE. dQ(K) = max(e1(K)*dQ(K-1),-0.5*TKE(K)) TKE(K) = max(TKE(K) + dQ(K), TKE_min) if (abs(dQ(K)) < roundoff*TKE(K)) exit enddo -#ifdef DEBUG - do K2=K+1,ke_kappa_prev+1 ; dQ(K2) = 0.0 ; dK(K2) = 0.0 ; enddo - do K=K2,nz+1 ; if (dQ(K) == 0.0) exit ; dQ(K) = 0.0 ; dK(K) = 0.0 ; enddo -#endif + if (debug_soln) then ; do K2=K+1,nz+1 ; dQ(K2) = 0.0 ; dK(K2) = 0.0 ; enddo ; endif endif if (.not. abort_Newton) then do K=ke_kappa,2,-1 @@ -1837,10 +1646,9 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(1) = 0.0 endif -#ifdef DEBUG ! Check these solutions for consistency. ! The unit conversions here have not been carefully tested. - do K=2,nz + if (debug_soln) then ; do K=2,nz ! In these equations, K_err_lin and Q_err_lin should be at round-off levels ! compared with the dominant terms, perhaps, dz_Int*I_Ld2*kappa and ! dz_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been @@ -1863,8 +1671,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & 0.5*(TKE_prev(K)-TKE_prev(K+1))*Idz(k) * (dK(K) + dK(K+1)) - & 0.5*(TKE_prev(K)-TKE_prev(K-1))*Idz(k-1)* (dK(K-1) + dK(K)) + & dz_Int(K) * (dK(K) * (S2(K) - N2(K)) - dQ(K)*TKE_decay(K)) - enddo -#endif + enddo ; endif + endif ! End of the Newton's method solver. ! Test kappa for convergence... @@ -1904,34 +1712,10 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & do K=2,nz ; K_Q(K) = kappa(K) / max(TKE(K), TKE_min) ; enddo endif -#ifdef DEBUG - if (itt <= max_debug_itt) then - do K=1,nz+1 - kprev_it1(K,itt) = kappa_prev(K) - kappa_it1(K,itt) = kappa(K) ; tke_it1(K,itt) = tke(K) - dkappa_it1(K,itt) = kappa(K) - kappa_prev(K) - dkappa_norm_it1(K,itt) = (kappa(K) - kappa_prev(K)) / & - (kappa0 + 0.5*(kappa(K) + kappa_prev(K))) - K_Q_it1(K,itt) = kappa(K) / max(TKE(K),TKE_min) - d_dkappa_it1(K,itt) = 0.0 - if (itt > 1) then ; if (abs(dkappa_it1(K,itt-1)) > 1e-20*US%m2_s_to_Z2_T) & - d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) - endif - enddo - endif -#endif - if (within_tolerance) exit enddo -#ifdef DEBUG - do it2=itt+1,max_debug_itt ; do K=1,nz+1 - kprev_it1(K,it2) = 0.0 ; kappa_it1(K,it2) = 0.0 ; tke_it1(K,it2) = 0.0 - dkappa_it1(K,it2) = 0.0 ; K_Q_it1(K,it2) = 0.0 ; d_dkappa_it1(K,it2) = 0.0 - enddo ; enddo -#endif - if (do_Newton) then ! K_Q needs to be calculated. do K=1,ks_kappa-1 ; K_Q(K) = 0.0 ; enddo do K=ks_kappa,ke_kappa ; K_Q(K) = kappa(K) / TKE(K) ; enddo @@ -2127,16 +1911,10 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag - CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear',diag%axesTi,Time, & + CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear', diag%axesTi, Time, & 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) - CS%id_TKE = register_diag_field('ocean_model','TKE_shear',diag%axesTi,Time, & + CS%id_TKE = register_diag_field('ocean_model','TKE_shear', diag%axesTi, Time, & 'Shear-driven Turbulent Kinetic Energy', 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**2) -#ifdef ADD_DIAGNOSTICS - CS%id_ILd2 = register_diag_field('ocean_model','ILd2_shear',diag%axesTi,Time, & - 'Inverse kappa decay scale at interfaces', 'm-2', conversion=US%m_to_Z**2) - CS%id_dz_Int = register_diag_field('ocean_model','dz_Int_shear',diag%axesTi,Time, & - 'Finite volume thickness of interfaces', 'm', conversion=US%Z_to_m) -#endif end function kappa_shear_init diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index f8a96c894b..f21faa359d 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -18,7 +18,6 @@ module MOM_regularize_layers implicit none ; private #include -#undef DEBUG_CODE public regularize_layers, regularize_layers_init @@ -58,18 +57,6 @@ module MOM_regularize_layers integer :: id_def_rat = -1 !< A diagnostic ID logical :: 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. -#ifdef DEBUG_CODE - !>@{ Diagnostic IDs - integer :: id_def_rat_2 = -1, id_def_rat_3 = -1 - integer :: id_def_rat_u = -1, id_def_rat_v = -1 - integer :: id_e1 = -1, id_e2 = -1, id_e3 = -1 - integer :: id_def_rat_u_1b = -1, id_def_rat_v_1b = -1 - integer :: id_def_rat_u_2 = -1, id_def_rat_u_2b = -1 - integer :: id_def_rat_v_2 = -1, id_def_rat_v_2b = -1 - integer :: id_def_rat_u_3 = -1, id_def_rat_u_3b = -1 - integer :: id_def_rat_v_3 = -1, id_def_rat_v_3b = -1 - !>@} -#endif end type regularize_layers_CS !>@{ Clock IDs @@ -148,17 +135,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & e ! The interface depths [H ~> m or kg m-2], positive upward. -#ifdef DEBUG_CODE - real, dimension(SZIB_(G),SZJ_(G)) :: & - def_rat_u_1b, def_rat_u_2, def_rat_u_2b, def_rat_u_3, def_rat_u_3b - real, dimension(SZI_(G),SZJB_(G)) :: & - def_rat_v_1b, def_rat_v_2, def_rat_v_2b, def_rat_v_3, def_rat_v_3b - real, dimension(SZI_(G),SZJB_(G)) :: & - def_rat_h2, def_rat_h3 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - ef ! The filtered interface depths [H ~> m or kg m-2], positive upward. -#endif - real, dimension(SZI_(G),SZK_(G)+1) :: & e_filt, e_2d ! The interface depths [H ~> m or kg m-2], positive upward. real, dimension(SZI_(G),SZK_(G)) :: & @@ -229,12 +205,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) h_neglect = GV%H_subroundoff debug = (debug .or. CS%debug) -#ifdef DEBUG_CODE - debug = .true. - if (CS%id_def_rat_2 > 0) then ! Calculate over a slightly larger domain. - is = G%isc-1 ; ie = G%iec+1 ; js = G%jsc-1 ; je = G%jec+1 - endif -#endif I_dtol = 1.0 / max(CS%h_def_tol2 - CS%h_def_tol1, 1e-40) I_dtol34 = 1.0 / max(CS%h_def_tol4 - CS%h_def_tol3, 1e-40) @@ -249,11 +219,8 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) e(i,j,K+1) = e(i,j,K) - h(i,j,k) enddo ; enddo ; enddo -#ifdef DEBUG_CODE - call find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, def_rat_u_1b, def_rat_v_1b, 1, h) -#else call find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h=h) -#endif + ! Determine which columns are problematic do j=js,je ; do_j(j) = .false. ; enddo do j=js,je ; do i=is,ie @@ -262,49 +229,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (def_rat_h(i,j) > CS%h_def_tol1) do_j(j) = .true. enddo ; enddo -#ifdef DEBUG_CODE - if ((CS%id_def_rat_3 > 0) .or. (CS%id_e3 > 0) .or. & - (CS%id_def_rat_u_3 > 0) .or. (CS%id_def_rat_u_3b > 0) .or. & - (CS%id_def_rat_v_3 > 0) .or. (CS%id_def_rat_v_3b > 0) ) then - do j=js-1,je+1 ; do i=is-1,ie+1 - ef(i,j,1) = 0.0 - enddo ; enddo - do K=2,nz+1 ; do j=js,je ; do i=is,ie - if (G%mask2dCu(I,j) <= 0.0) then ; e_e = e(i,j,K) ; else - e_e = max(e(i+1,j,K) + min(e(i,j,K) - e(i+1,j,nz+1), 0.0), e(i,j,nz+1)) - endif - if (G%mask2dCu(I-1,j) <= 0.0) then ; e_w = e(i,j,K) ; else - e_w = max(e(i-1,j,K) + min(e(i,j,K) - e(i-1,j,nz+1), 0.0), e(i,j,nz+1)) - endif - if (G%mask2dCv(i,J) <= 0.0) then ; e_n = e(i,j,K) ; else - e_n = max(e(i,j+1,K) + min(e(i,j,K) - e(i,j+1,nz+1), 0.0), e(i,j,nz+1)) - endif - if (G%mask2dCv(i,J-1) <= 0.0) then ; e_s = e(i,j,K) ; else - e_s = max(e(i,j-1,K) + min(e(i,j,K) - e(i,j-1,nz+1), 0.0), e(i,j,nz+1)) - endif - - wt = 1.0 - ef(i,j,k) = (1.0 - 0.5*wt) * e(i,j,K) + & - wt * 0.125 * ((e_e + e_w) + (e_n + e_s)) - enddo ; enddo ; enddo - call find_deficit_ratios(ef, def_rat_u_3, def_rat_v_3, G, GV, CS, def_rat_u_3b, def_rat_v_3b) - - ! Determine which columns are problematic - do j=js,je ; do i=is,ie - def_rat_h3(i,j) = max(def_rat_u_3(I-1,j), def_rat_u_3(I,j), & - def_rat_v_3(i,J-1), def_rat_v_3(i,J)) - enddo ; enddo - - if (CS%id_e3 > 0) call post_data(CS%id_e3, ef, CS%diag) - if (CS%id_def_rat_3 > 0) call post_data(CS%id_def_rat_3, def_rat_h3, CS%diag) - if (CS%id_def_rat_u_3 > 0) call post_data(CS%id_def_rat_u_3, def_rat_u_3, CS%diag) - if (CS%id_def_rat_u_3b > 0) call post_data(CS%id_def_rat_u_3b, def_rat_u_3b, CS%diag) - if (CS%id_def_rat_v_3 > 0) call post_data(CS%id_def_rat_v_3, def_rat_v_3, CS%diag) - if (CS%id_def_rat_v_3b > 0) call post_data(CS%id_def_rat_v_3b, def_rat_v_3b, CS%diag) - endif -#endif - - ! Now restructure the layers. !$OMP parallel do default(private) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,US, & !$OMP e,I_dtol,h,tv,debug,h_neglect,p_ref_cv,ea, & @@ -682,40 +606,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (CS%id_def_rat > 0) call post_data(CS%id_def_rat, def_rat_h, CS%diag) -#ifdef DEBUG_CODE - if (CS%id_e1 > 0) call post_data(CS%id_e1, e, CS%diag) - if (CS%id_def_rat_u > 0) call post_data(CS%id_def_rat_u, def_rat_u, CS%diag) - if (CS%id_def_rat_u_1b > 0) call post_data(CS%id_def_rat_u_1b, def_rat_u_1b, CS%diag) - if (CS%id_def_rat_v > 0) call post_data(CS%id_def_rat_v, def_rat_v, CS%diag) - if (CS%id_def_rat_v_1b > 0) call post_data(CS%id_def_rat_v_1b, def_rat_v_1b, CS%diag) - - if ((CS%id_def_rat_2 > 0) .or. & - (CS%id_def_rat_u_2 > 0) .or. (CS%id_def_rat_u_2b > 0) .or. & - (CS%id_def_rat_v_2 > 0) .or. (CS%id_def_rat_v_2b > 0) ) then - do j=js-1,je+1 ; do i=is-1,ie+1 - e(i,j,1) = 0.0 - enddo ; enddo - do K=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - e(i,j,K+1) = e(i,j,K) - h(i,j,k) - enddo ; enddo ; enddo - - call find_deficit_ratios(e, def_rat_u_2, def_rat_v_2, G, GV, CS, def_rat_u_2b, def_rat_v_2b, h=h) - - ! Determine which columns are problematic - do j=js,je ; do i=is,ie - def_rat_h2(i,j) = max(def_rat_u_2(I-1,j), def_rat_u_2(I,j), & - def_rat_v_2(i,J-1), def_rat_v_2(i,J)) - enddo ; enddo - - if (CS%id_def_rat_2 > 0) call post_data(CS%id_def_rat_2, def_rat_h2, CS%diag) - if (CS%id_e2 > 0) call post_data(CS%id_e2, e, CS%diag) - if (CS%id_def_rat_u_2 > 0) call post_data(CS%id_def_rat_u_2, def_rat_u_2, CS%diag) - if (CS%id_def_rat_u_2b > 0) call post_data(CS%id_def_rat_u_2b, def_rat_u_2b, CS%diag) - if (CS%id_def_rat_v_2 > 0) call post_data(CS%id_def_rat_v_2, def_rat_v_2, CS%diag) - if (CS%id_def_rat_v_2b > 0) call post_data(CS%id_def_rat_v_2b, def_rat_v_2b, CS%diag) - endif -#endif - end subroutine regularize_surface !> This subroutine determines the amount by which the harmonic mean @@ -958,45 +848,6 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) CS%id_def_rat = register_diag_field('ocean_model', 'deficit_ratio', diag%axesT1, & Time, 'Max face thickness deficit ratio', 'nondim') -#ifdef DEBUG_CODE - CS%id_def_rat_2 = register_diag_field('ocean_model', 'deficit_rat2', diag%axesT1, & - Time, 'Corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_3 = register_diag_field('ocean_model', 'deficit_rat3', diag%axesT1, & - Time, 'Filtered thickness deficit ratio', 'nondim') - CS%id_e1 = register_diag_field('ocean_model', 'er_1', diag%axesTi, & - Time, 'Intial interface depths before remapping', 'm') - CS%id_e2 = register_diag_field('ocean_model', 'er_2', diag%axesTi, & - Time, 'Intial interface depths after remapping', 'm') - CS%id_e3 = register_diag_field('ocean_model', 'er_3', diag%axesTi, & - Time, 'Intial interface depths filtered', 'm') - - CS%id_def_rat_u = register_diag_field('ocean_model', 'defrat_u', diag%axesCu1, & - Time, 'U-point thickness deficit ratio', 'nondim') - CS%id_def_rat_u_1b = register_diag_field('ocean_model', 'defrat_u_1b', diag%axesCu1, & - Time, 'U-point 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_u_2 = register_diag_field('ocean_model', 'defrat_u_2', diag%axesCu1, & - Time, 'U-point corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_u_2b = register_diag_field('ocean_model', 'defrat_u_2b', diag%axesCu1, & - Time, 'U-point corrected 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_u_3 = register_diag_field('ocean_model', 'defrat_u_3', diag%axesCu1, & - Time, 'U-point filtered thickness deficit ratio', 'nondim') - CS%id_def_rat_u_3b = register_diag_field('ocean_model', 'defrat_u_3b', diag%axesCu1, & - Time, 'U-point filtered 2-layer thickness deficit ratio', 'nondim') - - CS%id_def_rat_v = register_diag_field('ocean_model', 'defrat_v', diag%axesCv1, & - Time, 'V-point thickness deficit ratio', 'nondim') - CS%id_def_rat_v_1b = register_diag_field('ocean_model', 'defrat_v_1b', diag%axesCv1, & - Time, 'V-point 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_v_2 = register_diag_field('ocean_model', 'defrat_v_2', diag%axesCv1, & - Time, 'V-point corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_v_2b = register_diag_field('ocean_model', 'defrat_v_2b', diag%axesCv1, & - Time, 'V-point corrected 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_v_3 = register_diag_field('ocean_model', 'defrat_v_3', diag%axesCv1, & - Time, 'V-point filtered thickness deficit ratio', 'nondim') - CS%id_def_rat_v_3b = register_diag_field('ocean_model', 'defrat_v_3b', diag%axesCv1, & - Time, 'V-point filtered 2-layer thickness deficit ratio', 'nondim') -#endif - if (CS%allow_clocks_in_omp_loops) then id_clock_EOS = cpu_clock_id('(Ocean regularize_layers EOS)', grain=CLOCK_ROUTINE) endif diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 86f828e5fa..42babae7d8 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1677,7 +1677,9 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) logical :: domore, do_i(SZI_(G)) integer :: i, j, k, is, ie, js, je, nz + integer :: l_seg logical :: local_open_u_BC, local_open_v_BC + logical :: has_obc local_open_u_BC = .false. local_open_v_BC = .false. @@ -1718,15 +1720,21 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) do k=nz,1,-1 domore = .false. do i=is,ie ; if (do_i(i)) then + ! Determine if grid point is an OBC + has_obc = .false. if (local_open_v_BC) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - hvel = GV%H_to_Z*h(i,j,k) - else - hvel = GV%H_to_Z*h(i,j+1,k) - endif + l_seg = OBC%segnum_v(i,J) + if (l_seg /= OBC_NONE) then + has_obc = OBC%segment(l_seg)%open + endif + endif + + ! Compute h based on OBC state + if (has_obc) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + hvel = GV%H_to_Z*h(i,j,k) else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + hvel = GV%H_to_Z*h(i,j+1,k) endif else hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) @@ -1760,15 +1768,21 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo do k=nz,1,-1 ; domore = .false. do I=is-1,ie ; if (do_i(I)) then + ! Determine if grid point is an OBC + has_obc = .false. if (local_open_u_BC) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - hvel = GV%H_to_Z*h(i,j,k) - else - hvel = GV%H_to_Z*h(i+1,j,k) - endif - else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + l_seg = OBC%segnum_u(I,j) + if (l_seg /= OBC_NONE) then + has_obc = OBC%segment(l_seg)%open + endif + endif + + ! Compute h based on OBC state + if (has_obc) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + hvel = GV%H_to_Z*h(i,j,k) + else ! OBC_DIRECTION_W + hvel = GV%H_to_Z*h(i+1,j,k) endif else hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 6e1fd8fac9..1a4fb58e02 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -124,10 +124,18 @@ module MOM_vert_friction integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1, id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 + ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 + integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 !>@} type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() !< A pointer to the control structure !! for recording accelerations leading to velocity truncations + + ! real, pointer :: hf_du_dt_visc(:,:,:) => NULL() ! Zonal friction accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, pointer :: hf_dv_dt_visc(:,:,:) => NULL() ! Merdional friction accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + end type vertvisc_CS contains @@ -202,11 +210,14 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, allocatable, dimension(:,:) :: hf_du_dt_visc_2d ! Depth sum of hf_du_dt_visc [L T-2 ~> m s-2] + real, allocatable, dimension(:,:) :: hf_dv_dt_visc_2d ! Depth sum of hf_dv_dt_visc [L T-2 ~> m s-2] + logical :: do_i(SZIB_(G)) logical :: DoStokesMixing - integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz, n - is = G%isc ; ie = G%iec + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n + is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & @@ -453,6 +464,41 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (present(tauy_bot) .and. (CS%id_tauy_bot > 0)) & call post_data(CS%id_tauy_bot, tauy_bot, CS%diag) + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_du_dt_visc > 0) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_du_dt_visc(I,j,k) = ADp%du_dt_visc(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_du_dt_visc, CS%hf_du_dt_visc, CS%diag) + !endif + !if (CS%id_hf_dv_dt_visc > 0) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_dv_dt_visc(i,J,k) = ADp%dv_dt_visc(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_dv_dt_visc, CS%hf_dv_dt_visc, CS%diag) + !endif + if (CS%id_hf_du_dt_visc_2d > 0) then + allocate(hf_du_dt_visc_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_du_dt_visc_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_du_dt_visc_2d(I,j) = hf_du_dt_visc_2d(I,j) + ADp%du_dt_visc(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_du_dt_visc_2d, hf_du_dt_visc_2d, CS%diag) + deallocate(hf_du_dt_visc_2d) + endif + if (CS%id_hf_dv_dt_visc_2d > 0) then + allocate(hf_dv_dt_visc_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dv_dt_visc_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dv_dt_visc_2d(i,J) = hf_dv_dt_visc_2d(i,J) + ADp%dv_dt_visc(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dv_dt_visc_2d, hf_dv_dt_visc_2d, CS%diag) + deallocate(hf_dv_dt_visc_2d) + endif + end subroutine vertvisc !> Calculate the fraction of momentum originally in a layer that remains @@ -629,6 +675,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) real :: z2 ! The distance from the bottom, normalized by Hbbl, nondim. real :: z2_wt ! A nondimensional (0-1) weight used when calculating z2. real :: z_clear ! The clearance of an interface above the surrounding topography [H ~> m or kg m-2]. + real :: a_cpl_max ! The maximum drag doefficient across interfaces, set so that it will be + ! representable as a 32-bit float in MKS units [Z T-1 ~> m s-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -648,6 +696,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) "Module must be initialized before it is used.") h_neglect = GV%H_subroundoff + a_cpl_max = 1.0e37 * US%m_to_Z * US%T_to_s I_Hbbl(:) = 1.0 / (CS%Hbbl + h_neglect) I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val @@ -676,7 +725,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) endif !$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 OBC,h_neglect,dt,I_valBL,Kv_u,a_cpl_max) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo @@ -811,13 +860,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i_shelf(I)) then - CS%a_u(I,j,K) = forces%frac_shelf_u(I,j) * a_shelf(I,K) + & - (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K) + CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * a_shelf(I,K) + & + (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_u(I,j,K) = forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & -! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K) +! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & +! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) elseif (do_i(I)) then - CS%a_u(I,j,K) = a_cpl(I,K) + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K)) endif ; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i_shelf(I)) then ! Should we instead take the inverse of the average of the inverses? @@ -827,7 +876,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) CS%h_u(I,j,k) = hvel(I,k) + h_neglect endif ; enddo ; enddo else - do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = a_cpl(I,K) ; enddo ; enddo + do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K)) ; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) + h_neglect ; enddo ; enddo endif @@ -843,7 +892,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,US,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_v) & + !$OMP OBC,h_neglect,dt,I_valBL,Kv_v,a_cpl_max) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo @@ -979,13 +1028,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do i=is,ie ; if (do_i_shelf(i)) then - CS%a_v(i,J,K) = forces%frac_shelf_v(i,J) * a_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K) + CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * a_shelf(i,k) + & + (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_v(i,J,K) = forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & -! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K) +! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & + ! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) elseif (do_i(i)) then - CS%a_v(i,J,K) = a_cpl(i,K) + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K)) endif ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i_shelf(i)) then ! Should we instead take the inverse of the average of the inverses? @@ -995,7 +1044,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) CS%h_v(i,J,k) = hvel(i,k) + h_neglect endif ; enddo ; enddo else - do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = a_cpl(i,K) ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K)) ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) + h_neglect ; enddo ; enddo endif @@ -1094,12 +1143,12 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: z2 ! A copy of z_i [nondim] + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: topfn ! A function that is 1 at the top and small far from it [nondim] real :: kv_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] logical :: do_shelf, do_OBCs integer :: i, k, is, ie, max_nk integer :: nz - real :: botfn a_cpl(:,:) = 0.0 Kv_tot(:,:) = 0.0 @@ -1109,10 +1158,10 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, nz = G%ke h_neglect = GV%H_subroundoff - ! The maximum coupling coefficent was originally introduced to avoid - ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 - ! sets the maximum coupling coefficient increment to 1e10 m per timestep. if (CS%answers_2018) then + ! The maximum coupling coefficent was originally introduced to avoid + ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 + ! sets the maximum coupling coefficient increment to 1e10 m per timestep. I_amax = (1.0e-10*US%Z_to_m) * dt else I_amax = 0.0 @@ -1757,6 +1806,40 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + !CS%id_hf_du_dt_visc = register_diag_field('ocean_model', 'hf_du_dt_visc', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_du_dt_visc > 0) then + ! call safe_alloc_ptr(CS%hf_du_dt_visc,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_dv_dt_visc = register_diag_field('ocean_model', 'hf_dv_dt_visc', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_dv_dt_visc > 0) then + ! call safe_alloc_ptr(CS%hf_dv_dt_visc,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_du_dt_visc_2d = register_diag_field('ocean_model', 'hf_du_dt_visc_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if (CS%id_hf_du_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_dv_dt_visc_2d = register_diag_field('ocean_model', 'hf_dv_dt_visc_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dv_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + 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/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 7d2310b42f..466890349b 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -13,11 +13,6 @@ module MOM_generic_tracer #define _ALLOCATED allocated #endif - - ! ### These imports should not reach into FMS directly ### - use mpp_mod, only: stdout, mpp_error, FATAL,WARNING,NOTE - use field_manager_mod, only: fm_get_index,fm_string_len - use generic_tracer, only: generic_tracer_register, generic_tracer_get_diag_list use generic_tracer, only: generic_tracer_init, generic_tracer_source, generic_tracer_register_diag use generic_tracer, only: generic_tracer_coupler_get, generic_tracer_coupler_set @@ -29,7 +24,8 @@ module MOM_generic_tracer use g_tracer_utils, only: g_tracer_get_next,g_tracer_type,g_tracer_is_prog,g_tracer_flux_init use g_tracer_utils, only: g_tracer_send_diag,g_tracer_get_values use g_tracer_utils, only: g_tracer_get_pointer,g_tracer_get_alias,g_tracer_set_csdiag - + use g_tracer_utils, only: g_tracer_get_obc_segment_props + use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, get_diag_time_end use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe @@ -49,7 +45,8 @@ module MOM_generic_tracer use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs - use MOM_open_boundary, only : ocean_OBC_type + use MOM_open_boundary, only : ocean_OBC_type, register_obgc_segments, fill_obgc_segments + use MOM_open_boundary, only : set_obgc_segments_props use MOM_verticalGrid, only : verticalGrid_type @@ -58,6 +55,7 @@ module MOM_generic_tracer !> An state hidden in module data that is very much not allowed in MOM6 ! ### This needs to be fixed logical :: g_registered = .false. + integer, parameter :: fm_string_len=128 !>string lengths used in obgc packages public register_MOM_generic_tracer, initialize_MOM_generic_tracer public MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state @@ -69,19 +67,22 @@ module MOM_generic_tracer !> Control structure for generic tracers type, public :: MOM_generic_tracer_CS ; private - character(len = 200) :: IC_file !< The file in which the generic tracer initial values can - !! be found, or an empty string for internal initialization. - logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false. - real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers. - real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out. - logical :: tracers_may_reinit !< If true, tracers may go through the - !! initialization code if they are not found in the restart files. - - type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to - !! regulate the timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Restart control structure - - !> Pointer to the first element of the linked list of generic tracers. + character(len = 200) :: IC_file ! The file in which the generic tracer initial values can + ! be found, or an empty string for internal initialization. + logical :: Z_IC_file ! If true, the generic_tracer IC_file is in Z-space. The default is false. + real :: tracer_IC_val = 0.0 ! The initial value assigned to tracers. + real :: tracer_land_val = -1.0 ! The values of tracers used where land is masked out. + logical :: tracers_may_reinit ! If true, tracers may go through the + ! initialization code if they are not found in the + ! restart files. + + type(diag_ctrl), pointer :: diag => NULL() ! A structure that is used to + ! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() + type(ocean_OBC_type), pointer :: OBC => NULL() + ! The following pointer will be directed to the first element of the + ! linked list of generic tracers. + type(g_tracer_type), pointer :: g_tracer_list => NULL() integer :: H_to_m !< Auxiliary to access GV%H_to_m in routines that do not have access to GV @@ -96,7 +97,7 @@ module MOM_generic_tracer !> Initializes the generic tracer packages and adds their tracers to the list !! Adds the tracers in the list of generic tracers to the set of MOM tracers (i.e., MOM-register them) !! Register these tracers for restart - function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS, OBC) type(hor_index_type), intent(in) :: HI !< Horizontal index ranges type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters @@ -104,17 +105,20 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer !! advection and diffusion module. type(MOM_restart_CS), pointer :: restart_CS !< Pointer to the restart control structure. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. ! Local variables logical :: register_MOM_generic_tracer - - character(len=fm_string_len), parameter :: sub_name = 'register_MOM_generic_tracer' + logical :: obc_has + character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer' character(len=200) :: inputdir ! The directory where NetCDF input files are. ! These can be overridden later in via the field manager? integer :: ntau, k,i,j,axes(3) type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name,longname,units + character(len=fm_string_len) :: obc_src_file_name,obc_src_field_name real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr real, dimension(HI%isd:HI%ied, HI%jsd:HI%jed,GV%ke) :: grid_tmask @@ -122,7 +126,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_MOM_generic_tracer = .false. if (associated(CS)) then - call mpp_error(WARNING, "register_MOM_generic_tracer called with an "// & + call MOM_error(WARNING, "register_MOM_generic_tracer called with an "// & "associated control structure.") return endif @@ -159,7 +163,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "restart files of a restarted run.", default=.false.) CS%restart_CSp => restart_CS - + CS%OBC => OBC ntau=1 ! MOM needs the fields at only one time step @@ -185,7 +189,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Get the tracer list call generic_tracer_get_list(CS%g_tracer_list) - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") ! For each tracer name get its T_prog index and get its fields @@ -205,6 +209,13 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) name=g_tracer_name, longname=longname, units=units, & registry_diags=.false., & !### CHANGE TO TRUE? restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + if (associated(CS%OBC)) & + call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ,& + obc_src_file_name,obc_src_field_name ) + if(obc_has) then + call set_obgc_segments_props(g_tracer_name,obc_src_file_name,obc_src_field_name) + call register_obgc_segments(GV, CS%OBC, tr_Reg, param_file, g_tracer_name) + endif else call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & restart_CS, longname=longname, units=units) @@ -229,7 +240,7 @@ end function register_MOM_generic_tracer !! !! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. - subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, CS, & + subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, CS, & sponge_CSp, ALE_sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already been !! read from a restart file. @@ -240,15 +251,13 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(in) :: diag !< Regulates diagnostic output. - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, - !! where, and what open boundary conditions are used. type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the !! ALE sponges. - character(len=fm_string_len), parameter :: sub_name = 'initialize_MOM_generic_tracer' - logical :: OK + character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' + logical :: OK,obc_has integer :: i, j, k, isc, iec, jsc, jec, nk type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name @@ -265,7 +274,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, CS%diag=>diag !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") !For each tracer name get its fields g_tracer=>CS%g_tracer_list @@ -350,6 +359,8 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, endif endif + call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ) + if(obc_has .and. g_tracer_is_prog(g_tracer)) call fill_obgc_segments(G, CS%OBC, tr_ptr, g_tracer_name) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) if (.NOT. associated(g_tracer_next)) exit @@ -426,7 +437,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_column_physics' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_column_physics' type(g_tracer_type), pointer :: g_tracer, g_tracer_next character(len=fm_string_len) :: g_tracer_name @@ -443,7 +454,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = G%ke !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL,& trim(sub_name)//": No tracer in the list.") #ifdef _USE_MOM6_DIAG @@ -587,7 +598,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_stock' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -660,7 +671,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_min_max' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' real, dimension(:,:,:),pointer :: grid_tmask integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau @@ -728,7 +739,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) ! Local variables real :: sosga - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_surface_state' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke,1) :: rho0 real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke) :: dzt type(g_tracer_type), pointer :: g_tracer @@ -750,7 +761,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) tau=1,sosga=sosga,model_time=get_diag_time_end(CS%diag)) !Output diagnostics via diag_manager for all tracers in this module -! if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& +! if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ! "No tracer in the list.") ! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld @@ -767,7 +778,7 @@ subroutine MOM_generic_flux_init(verbosity) integer :: ind character(len=fm_string_len) :: g_tracer_name,longname, package,units,old_package,file_in,file_out real :: const_init_value - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_flux_init' + character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next if (.not. g_registered) then @@ -777,7 +788,7 @@ subroutine MOM_generic_flux_init(verbosity) call generic_tracer_get_list(g_tracer_list) if (.NOT. associated(g_tracer_list)) then - call mpp_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") + call MOM_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") return endif @@ -812,7 +823,7 @@ subroutine MOM_generic_tracer_get(name,member,array, CS) type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. real, dimension(:,:,:), pointer :: array_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_get' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr) array(:,:,:) = array_ptr(:,:,:) diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 21db2cfff4..119ad555da 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -4,7 +4,6 @@ module MOM_offline_aux ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use data_override_mod, only : data_override_init, data_override use MOM_time_manager, only : time_type, operator(-) use MOM_debugging, only : check_column_integrals @@ -12,7 +11,7 @@ module MOM_offline_aux use MOM_diag_vkernels, only : reintegrate_column use MOM_error_handler, only : callTree_enter, callTree_leave, MOM_error, FATAL, WARNING, is_root_pe use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_verticalGrid, only : verticalGrid_type use MOM_file_parser, only : get_param, log_version, param_file_type use astronomy_mod, only : orbital_time, diurnal_solar, daily_mean_solar diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index b7af9849b3..3895e8a116 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -4,7 +4,6 @@ module MOM_offline_main ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use MOM_ALE, only : ALE_CS, ALE_main_offline, ALE_offline_inputs use MOM_checksums, only : hchksum, uvchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end @@ -20,7 +19,7 @@ module MOM_offline_main use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_offline_aux, only : update_offline_from_arrays, update_offline_from_files use MOM_offline_aux, only : next_modulo_time, offline_add_diurnal_sw use MOM_offline_aux, only : update_h_horizontal_flux, update_h_vertical_flux, limit_mass_flux_3d diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 5868d60b46..e9c8fb0e7b 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -140,16 +140,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & !$OMP hprev,domore_k,js,je,is,ie,uhtr,vhtr,G,GV,h_end,& !$OMP uh_neglect,vh_neglect,ntr,Tr,h_prev_opt) -! This initializes the halos of uhr and vhr because pass_vector might do -! calculations on them, even though they are never used. -!$OMP do - + ! This initializes the halos of uhr and vhr because pass_vector might do + ! calculations on them, even though they are never used. + !$OMP do do k=1,nz do j=jsd,jed ; do I=IsdB,IedB ; uhr(I,j,k) = 0.0 ; enddo ; enddo do J=jsdB,jedB ; do i=Isd,Ied ; vhr(i,J,k) = 0.0 ; enddo ; enddo do j=jsd,jed ; do i=Isd,Ied ; hprev(i,j,k) = 0.0 ; enddo ; enddo domore_k(k)=1 -! Put the remaining (total) thickness fluxes into uhr and vhr. + ! Put the remaining (total) thickness fluxes into uhr and vhr. do j=js,je ; do I=is-1,ie ; uhr(I,j,k) = uhtr(I,j,k) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; vhr(i,J,k) = vhtr(i,J,k) ; enddo ; enddo if (.not. present(h_prev_opt)) then @@ -173,17 +172,17 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & enddo -!$OMP do + !$OMP do do j=jsd,jed ; do I=isd,ied-1 - uh_neglect(I,j) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i+1,j)) + uh_neglect(I,j) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i+1,j)) enddo ; enddo -!$OMP do + !$OMP do do J=jsd,jed-1 ; do i=isd,ied - vh_neglect(i,J) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i,j+1)) + vh_neglect(i,J) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i,j+1)) enddo ; enddo -!$OMP do ! initialize diagnostic fluxes and tendencies + !$OMP do do m=1,ntr if (associated(Tr(m)%ad_x)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied @@ -207,7 +206,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & do J=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_y(i,J) = 0.0 ; enddo ; enddo endif enddo -!$OMP end parallel + !$OMP end parallel isv = is ; iev = ie ; jsv = js ; jev = je @@ -222,8 +221,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! Reevaluate domore_u & domore_v unless the valid range is the same size as ! before. Also, do this if there is Strang splitting. if ((nsten_halo > 1) .or. (itt==1)) then -!$OMP parallel do default(none) shared(nz,domore_k,jsv,jev,domore_u,isv,iev,stencil, & -!$OMP uhr,domore_v,vhr) + !$OMP parallel do default(shared) do k=1,nz ; if (domore_k(k) > 0) then do j=jsv,jev ; if (.not.domore_u(j,k)) then do i=isv+stencil-1,iev-stencil; if (uhr(I,j,k) /= 0.0) then @@ -256,9 +254,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! for all the transport to happen. The sum over domore_k keeps the processors ! synchronized. This may not be very efficient, but it should be reliable. -!$OMP parallel default(private) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & -!$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & -!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) + !$OMP parallel default(shared) if (x_first) then @@ -305,7 +301,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & endif ! x_first -!$OMP end parallel + !$OMP end parallel ! If the advection just isn't finishing after max_iter, move on. if (itt >= max_iter) then @@ -385,6 +381,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. @@ -406,16 +403,15 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff -! do I=is-1,ie ; ts2(I) = 0.0 ; enddo do I=is-1,ie ; CFL(I) = 0.0 ; enddo do j=js,je ; if (domore_u(j,k)) then domore_u(j,k) = .false. - ! Calculate the i-direction profiles (slopes) of each tracer that - ! is being advected. + ! Calculate the i-direction profiles (slopes) of each tracer that is being advected. if (usePLMslope) then do m=1,ntr ; do i=is-stencil,ie+stencil !if (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) < & @@ -459,13 +455,13 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (segment%direction == OBC_DIRECTION_W) then T_tmp(i,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - T_tmp(I+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif else if (segment%direction == OBC_DIRECTION_W) then T_tmp(i,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc else - T_tmp(I+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -490,33 +486,33 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! in the cell plus whatever part of its half of the mass flux that ! the flux through the other side does not require. do I=is-1,ie - if (uhr(I,j,k) == 0.0) then + if ((uhr(I,j,k) == 0.0) .or. & + ((uhr(I,j,k) < 0.0) .and. (hprev(i+1,j,k) <= tiny_h)) .or. & + ((uhr(I,j,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then uhh(I) = 0.0 CFL(I) = 0.0 elseif (uhr(I,j,k) < 0.0) then hup = hprev(i+1,j,k) - G%areaT(i+1,j)*min_h - hlos = MAX(0.0,uhr(I+1,j,k)) + hlos = MAX(0.0, uhr(I+1,j,k)) if ((((hup - hlos) + uhr(I,j,k)) < 0.0) .and. & ((0.5*hup + uhr(I,j,k)) < 0.0)) then - uhh(I) = MIN(-0.5*hup,-hup+hlos,0.0) + uhh(I) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 + uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j))) - CFL(I) = - uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j)) ! CFL is positive + CFL(I) = - uhh(I) / (hprev(i+1,j,k)) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-uhr(I-1,j,k)) + hlos = MAX(0.0, -uhr(I-1,j,k)) if ((((hup - hlos) - uhr(I,j,k)) < 0.0) .and. & ((0.5*hup - uhr(I,j,k)) < 0.0)) then - uhh(I) = MAX(0.5*hup,hup-hlos,0.0) + uhh(I) = MAX(0.5*hup, hup-hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 - uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(I) = uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(I) = uhh(I) / (hprev(i,j,k)) ! CFL is positive endif enddo @@ -545,11 +541,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & dA = aR - aL ; mA = 0.5*( aR + aL ) if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells + aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then - aL = 3.*Tc - 2.*aR + aL = 3.*Tc - 2.*aR elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then - aR = 3.*Tc - 2.*aL + aR = 3.*Tc - 2.*aL endif a6 = 6.*Tc - 3. * (aR + aL) ! Curvature @@ -570,28 +566,17 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) - !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * slope_x(i,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i,m) flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i,j,k) + slope_x(i,m)*ts2(I)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) - !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * slope_x(i+1,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i+1,m) flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i+1,j,k) - slope_x(i+1,m)*ts2(I)) endif - !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect*G%areaT(i,j))) enddo ; enddo endif ! usePPM @@ -760,6 +745,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. @@ -777,8 +763,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff - !do i=is,ie ; ts2(i) = 0.0 ; enddo ! We conditionally perform work on tracer points: calculating the PLM slope, ! and updating tracer concentration within a cell @@ -822,7 +808,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! make a copy of the tracers in case values need to be overridden for OBCs - do j=G%jsd,G%jed; do m=1,ntr; do i=G%isd,G%ied + do j=G%jsd,G%jed ; do m=1,ntr ; do i=G%isd,G%ied T_tmp(i,m,j) = Tr(m)%t(i,j,k) enddo ; enddo ; enddo @@ -873,33 +859,33 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & domore_v(J,k) = .false. do i=is,ie - if (vhr(i,J,k) == 0.0) then + if ((vhr(i,J,k) == 0.0) .or. & + ((vhr(i,J,k) < 0.0) .and. (hprev(i,j+1,k) <= tiny_h)) .or. & + ((vhr(i,J,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then vhh(i,J) = 0.0 CFL(i) = 0.0 elseif (vhr(i,J,k) < 0.0) then hup = hprev(i,j+1,k) - G%areaT(i,j+1)*min_h - hlos = MAX(0.0,vhr(i,J+1,k)) + hlos = MAX(0.0, vhr(i,J+1,k)) if ((((hup - hlos) + vhr(i,J,k)) < 0.0) .and. & ((0.5*hup + vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MIN(-0.5*hup,-hup+hlos,0.0) + vhh(i,J) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 + vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) - CFL(i) = - vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) ! CFL is positive + CFL(i) = - vhh(i,J) / hprev(i,j+1,k) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-vhr(i,J-1,k)) + hlos = MAX(0.0, -vhr(i,J-1,k)) if ((((hup - hlos) - vhr(i,J,k)) < 0.0) .and. & ((0.5*hup - vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MAX(0.5*hup,hup-hlos,0.0) + vhh(i,J) = MAX(0.5*hup, hup-hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 - vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(i) = vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(i) = vhh(i,J) / hprev(i,j,k) ! CFL is positive endif enddo @@ -913,7 +899,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & endif ! Implementation of PPM-H3 - Tp = Tr(m)%t(i,j_up+1,k) ; Tc = Tr(m)%t(i,j_up,k) ; Tm = Tr(m)%t(i,j_up-1,k) + Tp = T_tmp(i,m,j_up+1) ; Tc = T_tmp(i,m,j_up) ; Tm = T_tmp(i,m,j_up-1) if (useHuynh) then aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate @@ -952,26 +938,16 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) - !flux_y(i,m,J) = vhh(i,J)*(aR - 0.5 * slope_y(i,m,j)*CFL(i)) - ! Alternative implementation of PLM - Tc = Tr(m)%t(i,j,k) + Tc = T_tmp(i,m,j) flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j,k) + slope_y(i,m,j)*ts2(i)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) - !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * slope_y(i,m,j+1)*CFL(i) ) - ! Alternative implementation of PLM - Tc = Tr(m)%t(i,j+1,k) + Tc = T_tmp(i,m,j+1) flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j+1,k) - slope_y(i,m,j+1)*ts2(i)) endif enddo ; enddo endif ! usePPM diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 5e9f01c7be..c41fa18032 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -138,7 +138,7 @@ end subroutine call_tracer_flux_init !> This subroutine determines which tracer packages are to be used and does the calls to !! register their tracers to be advected, diffused, and read from restarts. -subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) +subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS, OBC) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -151,7 +151,10 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) !! advection and diffusion module. type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control !! structure. - + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition + !! type specifies whether, where, + !! and what open boundary + !! conditions are used. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -239,7 +242,7 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) tr_Reg, restart_CS) if (CS%use_MOM_generic_tracer) CS%use_MOM_generic_tracer = & register_MOM_generic_tracer(HI, GV, param_file, CS%MOM_generic_tracer_CSp, & - tr_Reg, restart_CS) + tr_Reg, restart_CS, OBC) if (CS%use_pseudo_salt_tracer) CS%use_pseudo_salt_tracer = & register_pseudo_salt_tracer(HI, GV, param_file, CS%pseudo_salt_tracer_CSp, & tr_Reg, restart_CS) @@ -317,7 +320,7 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, & sponge_CSp) if (CS%use_MOM_generic_tracer) & - call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, & + call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, & CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) if (CS%use_pseudo_salt_tracer) & call initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 16ee280355..27ba8a42d9 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -847,6 +847,7 @@ subroutine tracer_name_lookup(Reg, tr_ptr, name) character(len=32), intent(in) :: name !< tracer name integer n + tr_ptr => null() do n=1,Reg%ntr if (lowercase(Reg%Tr(n)%name) == lowercase(name)) tr_ptr => Reg%Tr(n) enddo @@ -869,7 +870,7 @@ subroutine tracer_registry_init(param_file, Reg) else ; return ; endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", all_default=.true.) init_calls = init_calls + 1 if (init_calls > 1) then diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 028718f379..44c6c2e5a1 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -19,7 +19,7 @@ module RGC_tracer use MOM_forcing_type, only : forcing use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_restart, only : MOM_restart_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS, get_ALE_sponge_nz_data use MOM_sponge, only : set_up_sponge_field, sponge_CS @@ -207,8 +207,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & CS%tracer_IC_file) do m=1,NTR call query_vardesc(CS%tr_desc(m), name, caller="initialize_RGC_tracer") - call read_data(CS%tracer_IC_file, trim(name), & - CS%tr(:,:,:,m), domain=G%Domain%mpp_domain) + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) enddo else do m=1,NTR diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index a3215294fc..227c814b3c 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -242,20 +242,21 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + ! Use inside bathymetry + cff = sqrt(GV%g_Earth * G%bathyT(i+1,j) ) val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = (val2 * (val1 * cff * cosa / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + (G%bathyT(i+1,j) )) ) if (segment%nudged) then do k=1,nz segment%nudged_normal_vel(I,j,k) = (val2 * (val1 * cff * cosa / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + (G%bathyT(i+1,j))) ) enddo elseif (segment%specified) then do k=1,nz segment%normal_vel(I,j,k) = (val2 * (val1 * cff * cosa / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + (G%bathyT(i+1,j) )) ) segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) enddo endif @@ -285,16 +286,16 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) y1 = 1000. * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff =sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + cff =sqrt(GV%g_Earth * G%bathyT(i+1,j) ) val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & - ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) ) + ( 0.5*(G%bathyT(i+1,j+1) + G%bathyT(i+1,j) ) ) enddo ; endif enddo ; enddo endif - else + else ! Must be south isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do J=JsdB,JedB ; do i=isd,ied @@ -303,20 +304,20 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = US%L_T_to_m_s * (val1 * cff * sina / & - (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + (G%bathyT(i,j+1) )) * val2 if (segment%nudged) then do k=1,nz segment%nudged_normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & - (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + (G%bathyT(i,j+1) )) * val2 enddo elseif (segment%specified) then do k=1,nz segment%normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & - (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + (G%bathyT(i,j+1) )) * val2 segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) enddo endif @@ -344,11 +345,11 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) y1 = 1000. * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = ((val1 * val2 * cff * sina) / & - ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) )) + ( 0.5*((G%bathyT(i+1,j+1)) + G%bathyT(i,j+1))) ) enddo ; endif enddo ; enddo endif