From 620d9337a99a7cb21a2699ebbc60f23efb19a19b Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 5 Jul 2023 14:09:46 -0400 Subject: [PATCH 001/146] Autoconf: Find Python, even if PYTHON is empty The autoconf Python interpreter search was slightly modified to search for Python even if $PYTHON is set to an empty string. This is done by unsetting PYTHON if it is set but empty, then following the usual macro. This was required since `export PYTHON` in a Makefile will create the `PYTHON` variable but will assign it no value (i.e. empty string). This causes issues in some build environments. The backup `configure~` script was also added to the developer `ac-clean` cleanup rule. --- ac/Makefile.in | 1 + ac/configure.ac | 5 +++++ 2 files changed, 6 insertions(+) diff --git a/ac/Makefile.in b/ac/Makefile.in index 43262027e6..64a60e70d1 100644 --- a/ac/Makefile.in +++ b/ac/Makefile.in @@ -56,3 +56,4 @@ ac-clean: distclean rm -f @srcdir@/ac/aclocal.m4 rm -rf @srcdir@/ac/autom4te.cache rm -f @srcdir@/ac/configure + rm -f @srcdir@/ac/configure~ diff --git a/ac/configure.ac b/ac/configure.ac index 7ea1870816..9d87240506 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -238,8 +238,13 @@ AC_COMPILE_IFELSE( # Python interpreter test +# Declare the Python interpreter variable AC_ARG_VAR([PYTHON], [Python interpreter command]) +# If PYTHON is set to an empty string, then unset it +AS_VAR_IF([PYTHON], [], [AS_UNSET([PYTHON])], []) + +# Now attempt to find a Python interpreter if PYTHON is unset AS_VAR_SET_IF([PYTHON], [ AC_PATH_PROGS([PYTHON], ["$PYTHON"], [none]) ], [ From 77b588199839fd9b626c3d2e52f7afcde2f109e9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 18 Jun 2023 16:26:55 -0400 Subject: [PATCH 002/146] +Refactor nominal depth in ALE code Refactored 6 files in the ALE directory to calculate the nominal depth in thickness units in a single place (it is done in regridding_main now) and pass it to the various places where it is used, in a preparatory step to modify how this calculation is done in non-Boussinesq mode. There are new arguments to several publicly visible routines, including: - Add non_depth_H arguments to hybgen_regrid, build_zstar_grid, build_sigma_grid, build_rho_grid, build_grid_HyCOM1, build_grid_adaptive, build_adapt_column and build_grid_arbitrary - Add optional zScale arguments to build_zstar_grid and build_grid_HyCOM1 - Add unit_scale_type arguments to regridding_main, ALE_regrid_accelerated and ALE_offline_inputs Also eliminated an incorrect rescaling GV%Z_to_H facto when calculating the total column thickness from the layer thicknesses when an ice shelf is used with a Hycom grid. This would have caused dimensional consistency testing to fail. Added the new runtime parameters HYBGEN_H_THIN, HYBGEN_FAR_FROM_SURFACE HYBGEN_FAR_FROM_BOTTOM, and HYBGEN_DENSITY_EPSILON to set previously hard-coded dimensional parameters used in the Hybgen regridding code and store these values in new variables in hybgen_regrid_CS. Two of these are no longer passed to hybgen_column_regrid as separate parameters. By default these new runtime parameters recover the previous hard-coded values. Also eliminated an unused block of code in build_rho_column. Several comments documenting variables or their units were also added. All answers are bitwise identical, but there are 4 new runtime parameters that would appear in some MOM_parameter_doc files and there are changes to the arguments to 11 routines. --- src/ALE/MOM_ALE.F90 | 12 +- src/ALE/MOM_hybgen_regrid.F90 | 102 +++++--- src/ALE/MOM_regridding.F90 | 231 ++++++++++++------ src/ALE/coord_adapt.F90 | 14 +- src/ALE/coord_hycom.F90 | 4 +- src/ALE/coord_rho.F90 | 16 +- .../MOM_state_initialization.F90 | 4 +- src/tracer/MOM_offline_main.F90 | 2 +- 8 files changed, 241 insertions(+), 144 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index a341fd1835..61ab6c93cf 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -483,7 +483,7 @@ subroutine ALE_regrid( G, GV, US, h, h_new, dzRegrid, tv, CS, frac_shelf_h, PCM_ ! Build the new grid and store it in h_new. The old grid is retained as h. ! Both are needed for the subsequent remapping of variables. dzRegrid(:,:,:) = 0.0 - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, & + call regridding_main( CS%remapCS, CS%regridCS, G, GV, US, h, tv, h_new, dzRegrid, & frac_shelf_h=frac_shelf_h, PCM_cell=PCM_cell) if (CS%id_dzRegrid>0) then ; if (query_averaging_enabled(CS%diag)) then @@ -497,10 +497,11 @@ end subroutine ALE_regrid !> Regrid/remap stored fields used for offline tracer integrations. These input fields are assumed to have !! the same layer thicknesses at the end of the last offline interval (which should be a Zstar grid). This !! routine builds a grid on the runtime specified vertical coordinate -subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) +subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_grid_type), intent(in ) :: G !< Ocean grid informations type(verticalGrid_type), intent(in ) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure @@ -526,7 +527,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) ! Build new grid from the Zstar state onto the requested vertical coordinate. The new grid is stored ! in h_new. The old grid is h. Both are needed for the subsequent remapping of variables. Convective ! adjustment right now is not used because it is unclear what to do with vanished layers - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, US, h, tv, h_new, dzRegrid) if (CS%show_call_tree) call callTree_waypoint("new grid generated (ALE_offline_inputs)") ! Remap all variables from old grid h onto new grid h_new @@ -576,10 +577,11 @@ end subroutine ALE_offline_inputs !> For a state-based coordinate, accelerate the process of regridding by !! repeatedly applying the grid calculation algorithm -subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n_itt, u, v, OBC, Reg, dt, dzRegrid, initial) +subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, dt, dzRegrid, initial) type(ALE_CS), pointer :: CS !< ALE control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Original thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermo vars (T/S/EOS) @@ -651,7 +653,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n_itt, u, v, OBC, Reg, dt, d ! generate new grid if (CS%do_conv_adj) call convective_adjustment(G, GV, h_loc, tv_local) - call regridding_main(CS%remapCS, CS%regridCS, G, GV, h_loc, tv_local, h, dzInterface) + call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface) dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) ! remap from original grid onto new grid diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index dc7c90a079..524f9b8ff2 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -61,7 +61,21 @@ module MOM_hybgen_regrid !> Nominal density of interfaces [R ~> kg m-3] real, allocatable, dimension(:) :: target_density - real :: onem !< Nominally one m in thickness units [H ~> m or kg m-2] + real :: dp_far_from_sfc !< A distance that determines when an interface is suffiently far from + !! the surface that certain adjustments can be made in the Hybgen regridding + !! code [H ~> m or kg m-2]. In Hycom, this is set to tenm (nominally 10 m). + real :: dp_far_from_bot !< A distance that determines when an interface is suffiently far from + !! the bottom that certain adjustments can be made in the Hybgen regridding + !! code [H ~> m or kg m-2]. In Hycom, this is set to onem (nominally 1 m). + real :: h_thin !< A layer thickness below which a layer is considered to be too thin for + !! certain adjustments to be made in the Hybgen regridding code. + !! In Hycom, this is set to onemm (nominally 0.001 m). + + real :: rho_eps !< A small nonzero density that is used to prevent division by zero + !! in several expressions in the Hybgen regridding code [R ~> kg m-3]. + + real :: onem !< Nominally one m in thickness units [H ~> m or kg m-2], used only in + !! certain debugging tests. end type hybgen_regrid_CS @@ -166,6 +180,28 @@ subroutine init_hybgen_regrid(CS, GV, US, param_file) "A bottom boundary layer thickness within which Hybgen is able to move "//& "overlying layers upward to match a target density.", & units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_FAR_FROM_SURFACE", CS%dp_far_from_sfc, & + "A distance that determines when an interface is suffiently far "//& + "from the surface that certain adjustments can be made in the Hybgen "//& + "regridding code. In Hycom, this is set to tenm (nominally 10 m).", & + units="m", default=10.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_FAR_FROM_BOTTOM", CS%dp_far_from_bot, & + "A distance that determines when an interface is suffiently far "//& + "from the bottom that certain adjustments can be made in the Hybgen "//& + "regridding code. In Hycom, this is set to onem (nominally 1 m).", & + units="m", default=1.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_H_THIN", CS%h_thin, & + "A layer thickness below which a layer is considered to be too thin for "//& + "certain adjustments to be made in the Hybgen regridding code. "//& + "In Hycom, this is set to onemm (nominally 0.001 m).", & + units="m", default=0.001, scale=GV%m_to_H) + + call get_param(param_file, mdl, "HYBGEN_DENSITY_EPSILON", CS%rho_eps, & + "A small nonzero density that is used to prevent division by zero "//& + "in several expressions in the Hybgen regridding code.", & + units="kg m-3", default=1e-11, scale=US%kg_m3_to_R) + + call get_param(param_file, mdl, "HYBGEN_REMAP_DENSITY_MATCH", CS%hybiso, & "A tolerance between the layer densities and their target, within which "//& "Hybgen determines that remapping uses PCM for a layer.", & @@ -300,12 +336,17 @@ end subroutine get_hybgen_regrid_params !> Modify the input grid to give a new vertical grid based on the HYCOM hybgen code. -subroutine hybgen_regrid(G, GV, US, dp, tv, CS, dzInterface, PCM_cell) +subroutine hybgen_regrid(G, GV, US, dp, nom_depth_H, tv, CS, dzInterface, PCM_cell) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: dp !< Source grid layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(hybgen_regrid_CS), intent(in) :: CS !< hybgen control structure real, dimension(SZI_(G),SZJ_(G),CS%nk+1), & @@ -457,7 +498,7 @@ subroutine hybgen_regrid(G, GV, US, dp, tv, CS, dzInterface, PCM_cell) enddo ! The following block of code is used to trigger z* stretching of the targets heights. - nominalDepth = (G%bathyT(i,j) + G%Z_ref)*GV%Z_to_H + nominalDepth = nom_depth_H(i,j) if (h_tot <= CS%min_dilate*nominalDepth) then dilate = CS%min_dilate elseif (h_tot >= CS%max_dilate*nominalDepth) then @@ -482,8 +523,7 @@ subroutine hybgen_regrid(G, GV, US, dp, tv, CS, dzInterface, PCM_cell) enddo !k ! Determine the new layer thicknesses. - call hybgen_column_regrid(CS, nk, CS%thkbot, CS%onem, & - 1.0e-11*US%kg_m3_to_R, Rcv_tgt, fixlay, qhrlx, dp0ij, & + call hybgen_column_regrid(CS, nk, CS%thkbot, Rcv_tgt, fixlay, qhrlx, dp0ij, & dp0cum, Rcv, h_col, dz_int) ! Store the output from hybgenaij_regrid in 3-d arrays. @@ -669,13 +709,11 @@ real function cushn(delp, dp0) end function cushn !> Create a new grid for a column of water using the Hybgen algorithm. -subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & +subroutine hybgen_column_regrid(CS, nk, thkbot, Rcv_tgt, & fixlay, qhrlx, dp0ij, dp0cum, Rcv, h_in, dp_int) type(hybgen_regrid_CS), intent(in) :: CS !< hybgen regridding control structure integer, intent(in) :: nk !< number of layers real, intent(in) :: thkbot !< thickness of bottom boundary layer [H ~> m or kg m-2] - real, intent(in) :: onem !< one m in pressure units [H ~> m or kg m-2] - real, intent(in) :: epsil !< small nonzero density to prevent division by zero [R ~> kg m-3] real, intent(in) :: Rcv_tgt(nk) !< Target potential density [R ~> kg m-3] integer, intent(in) :: fixlay !< deepest fixed coordinate layer real, intent(in) :: qhrlx( nk+1) !< relaxation coefficient per timestep [nondim] @@ -702,20 +740,14 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & real :: h_hat0 ! A first guess at thickness movement upward across the interface ! between layers k and k-1 [H ~> m or kg m-2] real :: dh_cor ! Thickness changes [H ~> m or kg m-2] - real :: tenm ! ten m in pressure units [H ~> m or kg m-2] - real :: onemm ! one mm in pressure units [H ~> m or kg m-2] logical :: trap_errors integer :: k character(len=256) :: mesg ! A string for output messages ! This line needs to be consistent with the parameters set in cushn(). - real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn -! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn -! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn - - !### These hard-coded parameters should be changed to run-time variables. - tenm = 10.0*onem - onemm = 0.001*onem + real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn [nondim] +! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn [nondim] +! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn [nondim] trap_errors = .true. @@ -769,26 +801,26 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & ! Remap the non-fixed layers. - ! In the Hycom version, this loop was fused the loop correcting water that is + ! In the Hycom version, this loop was fused with the loop correcting water that is ! too light, and it ran down the water column, but if there are a set of layers ! that are very dense, that structure can lead to all of the water being remapped ! into a single thick layer. Splitting the loops and running the loop upwards - ! (as is done here avoids that catastrophic problem for layers that are far from + ! (as is done here) avoids that catastrophic problem for layers that are far from ! their targets. However, this code is still prone to a thin-thick-thin null mode. do k=nk,fixlay+2,-1 ! This is how the Hycom code would do this loop: do k=fixlay+1,nk ; if (k>fixlay+1) then - if ((Rcv(k) > Rcv_tgt(k) + epsil)) then + if ((Rcv(k) > Rcv_tgt(k) + CS%rho_eps)) then ! Water in layer k is too dense, so try to dilute with water from layer k-1 ! Do not move interface if k = fixlay + 1 if ((Rcv(k-1) >= Rcv_tgt(k-1)) .or. & - (p_int(k) <= dp0cum(k) + onem) .or. & + (p_int(k) <= dp0cum(k) + CS%dp_far_from_bot) .or. & (h_col(k) <= h_col(k-1))) then ! If layer k-1 is too light, there is a conflict in the direction the ! inteface between them should move, so thicken the thinner of the two. - if ((Rcv_tgt(k) - Rcv(k-1)) <= epsil) then + if ((Rcv_tgt(k) - Rcv(k-1)) <= CS%rho_eps) then ! layer k-1 is far too dense, take the entire layer ! If this code is working downward and this branch is repeated in a series ! of successive layers, it can accumulate into a very thick homogenous layers. @@ -814,7 +846,7 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & ! layer (thinner than its minimum thickness) in the interior ocean, ! move interface k-1 (and k-2 if necessary) upward ! Only work on layers that are sufficiently far from the fixed near-surface layers. - if ((h_hat >= 0.0) .and. (k > fixlay+2) .and. (p_int(k-1) > dp0cum(k-1) + tenm)) then + if ((h_hat >= 0.0) .and. (k > fixlay+2) .and. (p_int(k-1) > dp0cum(k-1) + CS%dp_far_from_sfc)) then ! Only act if interface k-1 is near the bottom or layer k-2 could donate water. if ( (p_int(nk+1) - p_int(k-1) < thkbot) .or. & @@ -828,7 +860,7 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) endif !fixlay+3:else - if (h_hat2 < -onemm) then + if (h_hat2 < -CS%h_thin) then dh_cor = qhrlx(k-1) * max(h_hat2, -h_hat - h_col(k-1)) h_col(k-2) = h_col(k-2) + dh_cor h_col(k-1) = h_col(k-1) - dh_cor @@ -838,9 +870,9 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) elseif (k <= fixlay+3) then ! Do nothing. - elseif (p_int(k-2) > dp0cum(k-2) + tenm .and. & - (p_int(nk+1) - p_int(k-2) < thkbot .or. & - h_col(k-3) > qqmx*dp0ij(k-3))) then + elseif ( (p_int(k-2) > dp0cum(k-2) + CS%dp_far_from_sfc) .and. & + ( (p_int(nk+1) - p_int(k-2) < thkbot) .or. & + (h_col(k-3) > qqmx*dp0ij(k-3)) ) ) then ! Determine how much water layer k-3 could supply without becoming too thin. if (k == fixlay+4) then @@ -850,7 +882,7 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & ! Maintain minimum thickess of layer k-3. h_hat3 = cushn(h_col(k-3) + (h_hat0 - h_hat), dp0ij(k-3)) - h_col(k-3) endif !fixlay+4:else - if (h_hat3 < -onemm) then + if (h_hat3 < -CS%h_thin) then ! Water is moved from layer k-3 to k-2, but do not dilute layer k-2 too much. dh_cor = qhrlx(k-2) * max(h_hat3, -h_col(k-2)) h_col(k-3) = h_col(k-3) + dh_cor @@ -860,7 +892,7 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & ! Now layer k-2 might be able donate to layer k-1. h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) - if (h_hat2 < -onemm) then + if (h_hat2 < -CS%h_thin) then dh_cor = qhrlx(k-1) * (max(h_hat2, -h_hat - h_col(k-1)) ) h_col(k-2) = h_col(k-2) + dh_cor h_col(k-1) = h_col(k-1) - dh_cor @@ -890,17 +922,17 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & enddo do k=fixlay+1,nk - if (Rcv(k) < Rcv_tgt(k) - epsil) then ! layer too light + if (Rcv(k) < Rcv_tgt(k) - CS%rho_eps) then ! layer too light ! Water in layer k is too light, so try to dilute with water from layer k+1. ! Entrainment is not possible if layer k touches the bottom. if (p_int(k+1) < p_int(nk+1)) then ! k 1.0e-13*max(p_int(nk+1), onem)) then + if (abs((h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1))) > 1.0e-13*max(p_int(nk+1), CS%onem)) then write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') & k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), (h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1)) call MOM_error(FATAL, "Mismatched thickness changes in hybgen_regrid: "//trim(mesg)) endif - if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), onem)) then + if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), CS%onem)) then write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",i4)') & k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), fixlay call MOM_error(FATAL, "Significantly negative final thickness in hybgen_regrid: "//trim(mesg)) endif enddo do K=1,nk+1 - if (abs(dp_int(K) - (p_int(K) - pres_in(K))) > 1.0e-13*max(p_int(nk+1), onem)) then + if (abs(dp_int(K) - (p_int(K) - pres_in(K))) > 1.0e-13*max(p_int(nk+1), CS%onem)) then call MOM_error(FATAL, "Mismatched interface height changes in hybgen_regrid.") endif enddo diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 9da4e95b24..c5f5807f66 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -175,7 +175,7 @@ module MOM_regridding character(len=*), parameter, public :: regriddingDefaultInterpScheme = "P1M_H2" !> Default mode for boundary extrapolation logical, parameter, public :: regriddingDefaultBoundaryExtrapolation = .false. -!> Default minimum thickness for some coordinate generation modes +!> Default minimum thickness for some coordinate generation modes [m] real, parameter, public :: regriddingDefaultMinThickness = 1.e-3 !> Maximum length of parameters @@ -213,7 +213,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m logical :: remap_answers_2018 integer :: remap_answer_date ! The vintage of the remapping expressions to use. integer :: regrid_answer_date ! The vintage of the regridding expressions to use. - real :: tmpReal, P_Ref + real :: tmpReal ! A temporary variable used in setting other variables [various] + real :: P_Ref ! The coordinate variable reference pression [R L2 T-2 ~> Pa] real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3] @@ -771,7 +772,7 @@ end subroutine end_regridding !------------------------------------------------------------------------------ !> Dispatching regridding routine for orchestrating regridding & remapping -subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, & +subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & frac_shelf_h, PCM_cell) !------------------------------------------------------------------------------ ! This routine takes care of (1) building a new grid and (2) remapping between @@ -795,45 +796,60 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, & type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after - !! the last time step + !! the last time step [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamical variables (T, S, ...) - real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target coordinate - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target + !! coordinate [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each + !! interface [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage [nomdim] logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out ) :: PCM_cell !< Use PCM remapping in cells where true ! Local variables + real :: nom_depth_H(SZI_(G),SZJ_(G)) !< The nominal ocean depth at each point in thickness units [H ~> m or kg m-2] + real :: Z_to_H ! A conversion factor used by some routines to convert coordinate + ! parameters to depth units [H Z-1 ~> nondim or kg m-3] real :: trickGnuCompiler integer :: i, j if (present(PCM_cell)) PCM_cell(:,:,:) = .false. + Z_to_H = US%Z_to_m * GV%m_to_H ! Often this is equivalent to GV%Z_to_H. + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + nom_depth_H(i,j) = (G%bathyT(i,j)+G%Z_ref) * Z_to_H + ! Consider using the following instead: + ! nom_depth_H(i,j) = max( (G%bathyT(i,j)+G%Z_ref) * Z_to_H , CS%min_nom_depth ) + ! if (G%mask2dT(i,j)==0.) nom_depth_H(i,j) = 0.0 + enddo ; enddo + select case ( CS%regridding_scheme ) case ( REGRIDDING_ZSTAR ) - call build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h ) + call build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_h, zScale=Z_to_H ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SIGMA_SHELF_ZSTAR) - call build_zstar_grid( CS, G, GV, h, dzInterface ) + call build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, zScale=Z_to_H ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SIGMA ) - call build_sigma_grid( CS, G, GV, h, dzInterface ) + call build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_RHO ) - call build_rho_grid( G, GV, G%US, h, tv, dzInterface, remapCS, CS, frac_shelf_h ) + call build_rho_grid( G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ARBITRARY ) - call build_grid_arbitrary( G, GV, h, dzInterface, trickGnuCompiler, CS ) + call build_grid_arbitrary( G, GV, h, nom_depth_H, dzInterface, trickGnuCompiler, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) - call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h ) + call build_grid_HyCOM1( G, GV, G%US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, & + frac_shelf_h, zScale=Z_to_H ) case ( REGRIDDING_HYBGEN ) - call hybgen_regrid(G, GV, G%US, h, tv, CS%hybgen_CS, dzInterface, PCM_cell) + call hybgen_regrid(G, GV, G%US, h, nom_depth_H, tv, CS%hybgen_CS, dzInterface, PCM_cell) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ADAPTIVE ) - call build_grid_adaptive(G, GV, G%US, h, tv, dzInterface, remapCS, CS) + call build_grid_adaptive(G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case default @@ -896,9 +912,12 @@ subroutine calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses (arbitrary units) - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions (same as h) - real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses (same as h) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses [H ~> m or kg m-2] + !! or other units + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions + !! in the same units as h [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses in the same + !! units as h [H ~> m or kg m-2] ! Local variables integer :: i, j, k, nki @@ -1121,21 +1140,29 @@ end subroutine filtered_grid_motion !> Builds a z*-coordinate grid with partial steps (Adcroft and Campin, 2004). !! z* is defined as !! z* = (z-eta)/(H+eta)*H s.t. z*=0 when z=eta and z*=-H when z=-H . -subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) +subroutine build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_h, zScale) ! Arguments type(regridding_CS), intent(in) :: CS !< Regridding 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 thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: frac_shelf_h !< Fractional !! ice shelf coverage [nondim]. + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate + !! resolution in Z to desired units for zInterface, + !! usually Z_to_H in which case it is in + !! units of [H Z-1 ~> nondim or kg m-3] ! Local variables real :: nominalDepth, minThickness, totalThickness ! Depths and thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ - real :: dh ! [H ~> m or kg m-2] + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] #endif real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] @@ -1146,13 +1173,13 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) minThickness = CS%min_thickness ice_shelf = present(frac_shelf_h) -!$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & -!$OMP ice_shelf,minThickness) & -!$OMP private(nominalDepth,totalThickness, & + !$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & + !$OMP ice_shelf,minThickness,zScale,nom_depth_H) & + !$OMP private(nominalDepth,totalThickness, & #ifdef __DO_SAFETY_CHECKS__ -!$OMP dh, & + !$OMP dh, & #endif -!$OMP zNew,zOld) + !$OMP zNew,zOld) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 @@ -1161,8 +1188,8 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) cycle endif - ! Local depth (G%bathyT is positive downward) - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + ! Local depth (positive downward) + nominalDepth = nom_depth_H(i,j) ! Determine water column thickness totalThickness = 0.0 @@ -1170,23 +1197,26 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) totalThickness = totalThickness + h(i,j,k) enddo + ! if (GV%Boussinesq) then zOld(nz+1) = - nominalDepth do k = nz,1,-1 zOld(k) = zOld(k+1) + h(i,j,k) enddo + ! else ! Work downward? + ! endif if (ice_shelf) then if (frac_shelf_h(i,j) > 0.) then ! under ice shelf call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, zNew, & - z_rigid_top = totalThickness-nominalDepth, & - eta_orig=zOld(1), zScale=GV%Z_to_H) + z_rigid_top=totalThickness-nominalDepth, & + eta_orig=zOld(1), zScale=zScale) else call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & - zNew, zScale=GV%Z_to_H) + zNew, zScale=zScale) endif else call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & - zNew, zScale=GV%Z_to_H) + zNew, zScale=zScale) endif ! Calculate the final change in grid position after blending new and old grids @@ -1225,7 +1255,7 @@ end subroutine build_zstar_grid !------------------------------------------------------------------------------ ! Build sigma grid !> This routine builds a grid based on terrain-following coordinates. -subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) +subroutine build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) !------------------------------------------------------------------------------ ! This routine builds a grid based on terrain-following coordinates. ! The module parameter coordinateResolution(:) determines the resolution in @@ -1238,18 +1268,22 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) 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 thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] ! Local variables - integer :: i, j, k - integer :: nz - real :: nominalDepth, totalThickness + real :: nominalDepth ! The nominal depth of the sea-floor in thickness units [H ~> m or kg m-2] + real :: totalThickness ! The total thickness of the water column [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ - real :: dh + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] #endif real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] + integer :: i, j, k, nz nz = GV%ke @@ -1261,28 +1295,35 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) cycle endif - ! The rest of the model defines grids integrating up from the bottom - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H - ! Determine water column height totalThickness = 0.0 do k = 1,nz totalThickness = totalThickness + h(i,j,k) enddo + ! In sigma coordinates, the bathymetric depth is only used as an arbitrary offset that + ! cancels out when determining coordinate motion, so referencing the column postions to + ! the surface is perfectly acceptable, but for preservation of previous answers the + ! referencing is done relative to the bottom when in Boussinesq mode. + ! if (GV%Boussinesq) then + nominalDepth = nom_depth_H(i,j) + ! else + ! nominalDepth = totalThickness + ! endif + call build_sigma_column(CS%sigma_CS, nominalDepth, totalThickness, zNew) ! Calculate the final change in grid position after blending new and old grids zOld(nz+1) = -nominalDepth do k = nz,1,-1 - zOld(k) = zOld(k+1) + h(i, j, k) + zOld(k) = zOld(k+1) + h(i,j,k) enddo call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) #ifdef __DO_SAFETY_CHECKS__ - dh=max(nominalDepth,totalThickness) - if (abs(zNew(1)-zOld(1))>(CS%nk-1)*0.5*epsilon(dh)*dh) then + dh = max(nominalDepth,totalThickness) + if (abs(zNew(1)-zOld(1)) > (CS%nk-1)*0.5*epsilon(dh)*dh) then write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz,CS%nk @@ -1314,11 +1355,11 @@ end subroutine build_sigma_grid ! Build grid based on target interface densities !------------------------------------------------------------------------------ !> This routine builds a new grid based on a given set of target interface densities. -subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shelf_h ) +subroutine build_rho_grid( G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) !------------------------------------------------------------------------------ ! This routine builds a new grid based on a given set of target interface ! densities (these target densities are computed by taking the mean value -! of given layer densities). The algorithn operates as follows within each +! of given layer densities). The algorithm operates as follows within each ! column: ! 1. Given T & S within each layer, the layer densities are computed. ! 2. Based on these layer densities, a global density profile is reconstructed @@ -1331,17 +1372,21 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel !------------------------------------------------------------------------------ ! Arguments - type(regridding_CS), intent(in) :: CS !< Regridding control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth - !! [H ~> m or kg m-2] - type(remapping_CS), intent(in) :: remapCS !< The remapping control structure - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice - !! shelf coverage [nondim] + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2] + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice + !! shelf coverage [nondim] ! Local variables integer :: nz ! The number of layers in the input grid integer :: i, j, k @@ -1351,7 +1396,7 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: totalThickness ! Total thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ - real :: dh + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] #endif logical :: ice_shelf @@ -1378,15 +1423,22 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel cycle endif - - ! Local depth (G%bathyT is positive downward) - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H - ! Determine total water column thickness totalThickness = 0.0 do k=1,nz totalThickness = totalThickness + h(i,j,k) enddo + + ! In rho coordinates, the bathymetric depth is only used as an arbitrary offset that + ! cancels out when determining coordinate motion, so referencing the column postions to + ! the surface is perfectly acceptable, but for preservation of previous answers the + ! referencing is done relative to the bottom when in Boussinesq mode. + ! if (GV%Boussinesq) then + nominalDepth = nom_depth_H(i,j) + ! else + ! nominalDepth = totalThickness + ! endif + ! Determine absolute interface positions zOld(nz+1) = - nominalDepth do k = nz,1,-1 @@ -1394,13 +1446,13 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel enddo if (ice_shelf) then - call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & - z_rigid_top = totalThickness - nominalDepth, eta_orig = zOld(1), & + call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i,j,:), & + tv%T(i,j,:), tv%S(i,j,:), tv%eqn_of_state, zNew, & + z_rigid_top=totalThickness - nominalDepth, eta_orig = zOld(1), & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) else - call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & + call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i,j,:), & + tv%T(i,j,:), tv%S(i,j,:), tv%eqn_of_state, zNew, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) endif @@ -1441,8 +1493,8 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel totalThickness = totalThickness + h(i,j,k) enddo - dh=max(nominalDepth,totalThickness) - if (abs(zNew(1)-zOld(1))>(nz-1)*0.5*epsilon(dh)*dh) then + dh = max(nominalDepth, totalThickness) + if (abs(zNew(1)-zOld(1)) > (nz-1)*0.5*epsilon(dh)*dh) then write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'zNew(1)-zOld(1) = ',zNew(1)-zOld(1),epsilon(dh),nz @@ -1475,11 +1527,15 @@ end subroutine build_rho_grid !! \remark { Based on Bleck, 2002: An ocean-ice general circulation model framed in !! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88. !! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 } -subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h ) +subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h, zScale ) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(remapping_CS), intent(in) :: remapCS !< The remapping control structure type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1487,6 +1543,10 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice shelf !! coverage [nondim] + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate + !! resolution in Z to desired units for zInterface, + !! usually Z_to_H in which case it is in + !! units of [H Z-1 ~> nondim or kg m-3] ! Local variables real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] @@ -1517,12 +1577,12 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) then - nominalDepth = (G%bathyT(i,j)+G%Z_ref) * GV%Z_to_H + nominalDepth = nom_depth_H(i,j) if (ice_shelf) then totalThickness = 0.0 do k=1,GV%ke - totalThickness = totalThickness + h(i,j,k) * GV%Z_to_H + totalThickness = totalThickness + h(i,j,k) enddo z_top_col = max(nominalDepth-totalThickness,0.0) else @@ -1538,7 +1598,7 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, nominalDepth, & h(i,j,:), tv%T(i,j,:), tv%S(i,j,:), p_col, & - z_col, z_col_new, zScale=GV%Z_to_H, & + z_col, z_col_new, zScale=zScale, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Calculate the final change in grid position after blending new and old grids @@ -1562,11 +1622,15 @@ end subroutine build_grid_HyCOM1 !> This subroutine builds an adaptive grid that follows density surfaces where !! possible, subject to constraints on the smoothness of interface heights. -subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) +subroutine build_grid_adaptive(G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1576,8 +1640,8 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) ! local variables integer :: i, j, k, nz ! indices and dimension lengths - ! temperature [C ~> degC], salinity [S ~> ppt] and pressure on interfaces - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: tInt, sInt + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: tInt ! Temperature on interfaces [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: sInt ! Salinity on interfaces [S ~> ppt] ! current interface positions and after tendency term is applied ! positive downward real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zInt ! Interface depths [H ~> m or kg m-2] @@ -1614,7 +1678,7 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) cycle endif - call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNext) + call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, nom_depth_H, zNext) call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:)) ! convert from depth to z @@ -1685,7 +1749,7 @@ end subroutine adjust_interface_motion !------------------------------------------------------------------------------ ! Build arbitrary grid !------------------------------------------------------------------------------ -subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) +subroutine build_grid_arbitrary( G, GV, h, nom_depth_H, dzInterface, h_new, CS ) !------------------------------------------------------------------------------ ! This routine builds a grid based on arbitrary rules !------------------------------------------------------------------------------ @@ -1694,6 +1758,10 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) 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 !< Original layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(regridding_CS), intent(in) :: CS !< Regridding control structure real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface !! depth [H ~> m or kg m-2] @@ -1718,7 +1786,7 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) do i = G%isc-1,G%iec+1 ! Local depth - local_depth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + local_depth = nom_depth_H(i,j) ! Determine water column height total_height = 0.0 @@ -2373,7 +2441,7 @@ function getStaticThickness( CS, SSH, depth ) real, dimension(CS%nk) :: getStaticThickness !< The returned thicknesses in the units of depth ! Local integer :: k - real :: z, dz + real :: z, dz ! Vertical positions and grid spacing [Z ~> m] select case ( CS%regridding_scheme ) case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & @@ -2407,10 +2475,13 @@ end function getStaticThickness subroutine dz_function1( string, dz ) character(len=*), intent(in) :: string !< String with list of parameters in form !! dz_min, H_total, power, precision - real, dimension(:), intent(inout) :: dz !< Profile of nominal thicknesses + real, dimension(:), intent(inout) :: dz !< Profile of nominal thicknesses [m] or other units ! Local variables integer :: nk, k - real :: dz_min, power, prec, H_total + real :: dz_min ! minimum grid spacing [m] or other units + real :: power ! A power to raise the relative position in index space [nondim] + real :: prec ! The precision with which positions are returned [m] or other units + real :: H_total ! The sum of the nominal thicknesses [m] or other units nk = size(dz) ! Number of cells prec = -1024. diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index 91df78c021..ee612788c9 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -112,7 +112,7 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom if (present(adaptDoMin)) CS%adaptDoMin = adaptDoMin end subroutine set_adapt_params -subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNext) +subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, nom_depth_H, zNext) type(adapt_CS), intent(in) :: CS !< The control structure for this module type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -125,6 +125,10 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: tInt !< Interface temperatures [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: sInt !< Interface salinities [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] real, dimension(SZK_(GV)+1), intent(inout) :: zNext !< updated interface positions ! Local variables @@ -144,7 +148,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex zNext(nz+1) = zInt(i,j,nz+1) ! local depth for scaling diffusivity - depth = (G%bathyT(i,j) + G%Z_ref) * GV%Z_to_H + depth = nom_depth_H(i,j) ! initialize del2sigma and the thickness change response to it zero del2sigma(:) = 0.0 ; dh_d2s(:) = 0.0 @@ -244,9 +248,9 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex ! set vertical grid diffusivity kGrid(k) = (CS%adaptTimeRatio * nz**2 * depth) * & - (CS%adaptZoomCoeff / (CS%adaptZoom + 0.5*(zNext(K) + zNext(K+1))) + & - (CS%adaptBuoyCoeff * drdz / CS%adaptDrho0) + & - max(1.0 - CS%adaptZoomCoeff - CS%adaptBuoyCoeff, 0.0) / depth) + ( CS%adaptZoomCoeff / (CS%adaptZoom + 0.5*(zNext(K) + zNext(K+1))) + & + (CS%adaptBuoyCoeff * drdz / CS%adaptDrho0) + & + max(1.0 - CS%adaptZoomCoeff - CS%adaptBuoyCoeff, 0.0) / depth) enddo ! initial denominator (first diagonal element) diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index aa2715eb42..ddc569e45e 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -117,7 +117,8 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(CS%nk+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] real, optional, intent(in) :: zScale !< Scaling factor from the input coordinate thicknesses in [Z ~> m] - !! to desired units for zInterface, perhaps GV%Z_to_H. + !! to desired units for zInterface, perhaps GV%Z_to_H in which + !! case this has units of [H Z-1 ~> nondim or kg m-3] real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of !! cell reconstruction [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of @@ -220,7 +221,6 @@ subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(nz), intent(in) :: p_col !< Layer pressure [R L2 T-2 ~> Pa] - !! to desired units for zInterface, perhaps GV%Z_to_H. real, dimension(nz), intent(out) :: R !< Layer density [R ~> kg m-3] real, dimension(nz+1), intent(out) :: RiAnom !< The interface density anomaly !! w.r.t. the interface target diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 8454c4be1d..7b6c0e0f8c 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -102,9 +102,9 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & real, dimension(CS%nk+1), & intent(inout) :: z_interface !< Absolute positions of interfaces real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (positive upward in the same - !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + !! units as depth) [H ~> m or kg m-2] real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same - !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + !! units as depth) [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose !! of cell reconstructions [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose @@ -119,22 +119,10 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & real, dimension(nz+1) :: xTmp ! Temporary positions [H ~> m or kg m-2] real, dimension(CS%nk) :: h_new ! New thicknesses [H ~> m or kg m-2] real, dimension(CS%nk+1) :: x1 ! Interface heights [H ~> m or kg m-2] - real :: z0_top, eta ! Thicknesses or heights [Z ~> m] or [H ~> m or kg m-2] ! Construct source column with vanished layers removed (stored in h_nv) call copy_finite_thicknesses(nz, h, CS%min_thickness, count_nonzero_layers, h_nv, mapping) - z0_top = 0. - eta=0.0 - if (present(z_rigid_top)) then - z0_top = z_rigid_top - eta=z0_top - if (present(eta_orig)) then - eta=eta_orig - endif - endif - - if (count_nonzero_layers > 1) then xTmp(1) = 0.0 do k = 1,count_nonzero_layers diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0321d7511a..802fd33d0f 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -464,7 +464,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (new_sim .and. debug) & call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) - call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & + call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & dt=dt, initial=.true.) endif endif @@ -2787,7 +2787,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore) if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc) - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, & + call regridding_main( remapCS, regridCS, G, GV_loc, US, h1, tv_loc, h, dz_interface, & frac_shelf_h=frac_shelf_h ) deallocate( dz_interface ) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 40dced9b20..0577a12ac5 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -1069,7 +1069,7 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) call pass_var(h, G%Domain) call pass_var(CS%tv%T, G%Domain) call pass_var(CS%tv%S, G%Domain) - call ALE_offline_inputs(CS%ALE_CSp, G, GV, h, CS%tv, CS%tracer_Reg, CS%uhtr, CS%vhtr, CS%Kd, & + call ALE_offline_inputs(CS%ALE_CSp, G, GV, US, h, CS%tv, CS%tracer_Reg, CS%uhtr, CS%vhtr, CS%Kd, & CS%debug, CS%OBC) if (CS%id_temp_regrid>0) call post_data(CS%id_temp_regrid, CS%tv%T, CS%diag) if (CS%id_salt_regrid>0) call post_data(CS%id_salt_regrid, CS%tv%S, CS%diag) From 7970347eb3f36f80583ddaf74358bab9a0cb32ae Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 1 Jun 2023 10:58:40 -0400 Subject: [PATCH 003/146] Add restart subroutine to MOM.F90 As described in issue #372, I would like to be able to create restart files that contain information about the particle location. These files will be written at the same time as other restart files. I cannot add these calls directly to the driver, because the driver does not have information about the particle location. We have added save_MOM6_internal_state as a subroutine in MOM.F90, and we added calls to this subroutine from each of the drivers. We hope this will allow for more new packages to write restart files in the future. Co-authored by Spencer Jones --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 6 +++- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 5 +++- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 8 ++++- config_src/drivers/solo_driver/MOM_driver.F90 | 6 +++- src/core/MOM.F90 | 30 +++++++++++++++---- 5 files changed, 46 insertions(+), 9 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 005e3a6723..bd86a633c6 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -14,7 +14,7 @@ module ocean_model_mod use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline +use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type @@ -700,6 +700,7 @@ subroutine ocean_model_restart(OS, timestamp) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -709,6 +710,7 @@ subroutine ocean_model_restart(OS, timestamp) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif end subroutine ocean_model_restart @@ -764,6 +766,8 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) + end subroutine ocean_model_save_restart !> Initialize the public ocean type diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 1a15760d00..cdf93b1bef 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -14,7 +14,7 @@ module MOM_ocean_model_mct use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline +use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging @@ -697,6 +697,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) else if (BTEST(OS%Restart_control,1)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -706,6 +707,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -715,6 +717,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif endif diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 1283b98ba0..205dbdadcc 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -14,7 +14,7 @@ module MOM_ocean_model_nuopc use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline +use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging @@ -738,6 +738,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) endif + + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) else if (BTEST(OS%Restart_control,1)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -747,6 +749,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -756,6 +759,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif endif if (present(stoch_restartname)) then @@ -818,6 +822,8 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_start(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) + end subroutine ocean_model_save_restart !> Initialize the public ocean type diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 974843c10f..72981122f2 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -31,7 +31,7 @@ program MOM6 use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized - use MOM, only : step_offline + use MOM, only : step_offline, save_MOM6_internal_state use MOM_coms, only : Set_PElist use MOM_domains, only : MOM_infra_init, MOM_infra_end, set_MOM_thread_affinity use MOM_ensemble_manager, only : ensemble_manager_init, get_ensemble_size @@ -570,6 +570,7 @@ program MOM6 dirs%restart_output_dir, .true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir, .true.) + call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time, .true.) endif if (BTEST(Restart_control,0)) then call save_restart(dirs%restart_output_dir, Time, grid, & @@ -578,6 +579,7 @@ program MOM6 dirs%restart_output_dir) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) + call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time) endif restart_time = restart_time + restint endif @@ -601,6 +603,8 @@ program MOM6 call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) + call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time) + ! Write the ocean solo restart file. call write_ocean_solo_res(Time, Start_time, calendar_type, & trim(dirs%restart_output_dir)//'ocean_solo.res') diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 7b9f2f9d3f..ba04bf27dd 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -438,7 +438,7 @@ module MOM end type MOM_control_struct public initialize_MOM, finish_MOM_initialization, MOM_end -public step_MOM, step_offline +public step_MOM, step_offline, save_MOM6_internal_state public extract_surface_state, get_ocean_stocks public get_MOM_state_elements, MOM_state_is_synchronized public allocate_surface_state, deallocate_surface_state @@ -3904,14 +3904,34 @@ subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) end subroutine get_ocean_stocks + +!> Trigger a writing of restarts for the MOM6 internal state +!! +!! Currently this applies to the state that does not take the form +!! of simple arrays for which the generic save_restart() function +!! can be used. +!! +!! Todo: +!! [ ] update particles to use Time and directories +!! [ ] move the call to generic save_restart() in here. +subroutine save_MOM6_internal_state(CS, dirs, time, stamp_time) + type(MOM_control_struct), intent(inout) :: CS !< MOM control structure + character(len=*), intent(in) :: dirs !< The directory where the restart + !! files are to be written + type(time_type), intent(in) :: time !< The current model time + logical, optional, intent(in) :: stamp_time !< If present and true, add time-stamp + + ! Could call save_restart(CS%restart_CSp) here + + if (CS%use_particles) call particles_save_restart(CS%particles) + +end subroutine save_MOM6_internal_state + + !> End of ocean model, including memory deallocation subroutine MOM_end(CS) type(MOM_control_struct), intent(inout) :: CS !< MOM control structure - if (CS%use_particles) then - call particles_save_restart(CS%particles) - endif - call MOM_sum_output_end(CS%sum_output_CSp) if (CS%use_ALE_algorithm) call ALE_end(CS%ALE_CSp) From 37ee5cc8a9dbdf2f746b7e7d36de8b6518cb84a9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 26 Jun 2023 17:24:41 -0400 Subject: [PATCH 004/146] +Add tv%valid_SpV_halo to debug non-Boussinesq mode Added the integer valid_SpV_halo to the thermo_var_ptrs type to indicate whether the SpV_array has been updated and its valid halo size, to facilitate error detection and debugging in non-Boussinesq mode. Tv%valid_SpV_halo is set to the halo size in calc_derived_thermo or after a halo update is done to tv%SpV_avg, and it is set to a negative value right after calls that change temperatures and salinities (such as by ALE remapping) unless there is a call to calc_derived_thermo. Tests for the validity of tv%SpV_avg are added to the routines behind thickness_to_dz, with fatal errors issued if invalid arrays would be used, but more tests could perhaps be used in any parameterization routines where tv%SpV_avg is used directly. Handling the updates to tv%SpV_avg this way helps to avoid unnecessary calls to calc_derived_thermo, which in turn has equation of state calls that can be expensive, while also providing essential verification of new code related to the non-Boussinesq code. These tests can probably be commented out or removed for efficiency once there is a full suite of regression tests for the fully non-Boussinesq mode of MOM6. In addition, a new optional debug argument was added to calc_derived_thermo which can be used to triggers checksums for the variables used to calculate tv%SpV_avg. One call to calc_derived_thermo was also added just before the initialization call to ALE_regrid that will be needed with the next commit, but does not change answers yet. All answers are bitwise identical, but there is a new element in a transparent and widely used type and a new optional argument to a public interface. --- src/ALE/MOM_ALE.F90 | 6 ++++ src/core/MOM.F90 | 24 ++++++++++---- src/core/MOM_interface_heights.F90 | 51 +++++++++++++++++++++++++----- src/core/MOM_variables.F90 | 2 ++ src/tracer/MOM_offline_main.F90 | 1 + 5 files changed, 70 insertions(+), 14 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 61ab6c93cf..4641747115 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -532,6 +532,7 @@ subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, ! Remap all variables from old grid h onto new grid h_new call ALE_remap_tracers(CS, G, GV, h, h_new, Reg, debug=CS%show_call_tree) + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_inputs)") ! Reintegrate mass transports from Zstar to the offline vertical coordinate @@ -571,6 +572,8 @@ subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, h(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + if (CS%show_call_tree) call callTree_leave("ALE_offline_inputs()") end subroutine ALE_offline_inputs @@ -674,6 +677,9 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) + + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + end subroutine ALE_regrid_accelerated !> This routine takes care of remapping all tracer variables between the old and the diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ba04bf27dd..703514fc52 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -671,8 +671,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt_therm = dt ; ntstep = 1 if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf CS%tv%p_surf => NULL() - if (associated(fluxes%p_surf)) then - if (CS%use_p_surf_in_EOS) CS%tv%p_surf => fluxes%p_surf + if (CS%use_p_surf_in_EOS .and. associated(fluxes%p_surf)) then + CS%tv%p_surf => fluxes%p_surf + if (allocated(CS%tv%SpV_avg)) call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) endif if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif @@ -1110,6 +1111,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif if (CS%interface_filter) then + if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass) + CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo) call cpu_clock_begin(id_clock_int_filter) call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & CS%CDp, CS%interface_filter_CSp) @@ -1245,6 +1248,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif if (CS%interface_filter) then + if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass) + CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo) call cpu_clock_begin(id_clock_int_filter) call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & CS%CDp, CS%interface_filter_CSp) @@ -1392,6 +1397,8 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) if (associated(CS%tv%T)) then call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + ! The bottom boundary layer calculation may need halo values of SpV_avg, including the corners. + if (allocated(CS%tv%SpV_avg)) halo_sz = max(halo_sz, 1) if (halo_sz > 0) then call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All, halo=halo_sz) call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All, halo=halo_sz) @@ -1407,7 +1414,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) ! Update derived thermodynamic quantities. if (allocated(CS%tv%SpV_avg)) then - call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz, debug=CS%debug) endif endif @@ -1559,6 +1566,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! Remap all variables from the old grid h onto the new grid h_new call ALE_remap_tracers(CS%ALE_CSp, G, GV, h, h_new, CS%tracer_Reg, showCallTree, dtdia, PCM_cell) call ALE_remap_velocities(CS%ALE_CSp, G, GV, h, h_new, u, v, CS%OBC, dzRegrid, showCallTree, dtdia) + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. if (CS%remap_aux_vars) then if (CS%split) & @@ -1591,7 +1599,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! Update derived thermodynamic quantities. if (allocated(tv%SpV_avg)) then - call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil) + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif if (CS%debug .and. CS%use_ALE_algorithm) then @@ -1647,7 +1655,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! Update derived thermodynamic quantities. if (allocated(tv%SpV_avg)) then - call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil) + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif endif @@ -1820,6 +1828,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! are used are intended to ensure that in the case where transports don't quite conserve, ! the offline layer thicknesses do not drift too far away from the online model. call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, debug=CS%debug) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. ! Update the tracer grid. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 @@ -2847,6 +2856,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Allocate any derived equation of state fields. if (use_temperature .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then allocate(CS%tv%SpV_avg(isd:ied,jsd:jed,nz), source=0.0) + CS%tv%valid_SpV_halo = -1 ! This array does not yet have any valid data. endif if (use_ice_shelf .and. CS%debug) then @@ -2895,6 +2905,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") call adjustGridForIntegrity(CS%ALE_CSp, G, GV, CS%h ) + if (allocated(CS%tv%SpV_avg)) call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=1) call pre_ALE_adjustments(G, GV, US, CS%h, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%u, CS%v) call callTree_waypoint("Calling ALE_regrid() to remap initial conditions (initialize_MOM)") @@ -2911,6 +2922,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Remap all variables from the old grid h onto the new grid h_new call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, CS%debug, PCM_cell=PCM_cell) call ALE_remap_velocities(CS%ALE_CSp, G, GV, CS%h, h_new, CS%u, CS%v, CS%OBC, dzRegrid, debug=CS%debug) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. ! Replace the old grid with new one. All remapping must be done at this point. !$OMP parallel do default(shared) @@ -3137,7 +3149,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Update derived thermodynamic quantities. if (allocated(CS%tv%SpV_avg)) then - call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil) + call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif if (associated(CS%visc%Kv_shear)) & diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index befeb1c2ad..dfd1048b82 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -4,13 +4,14 @@ module MOM_interface_heights ! This file is part of MOM6. See LICENSE.md for the license. use MOM_density_integrals, only : int_specific_vol_dp, avg_specific_vol +use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, FATAL -use MOM_EOS, only : calculate_density, EOS_type, EOS_domain -use MOM_file_parser, only : log_version -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, average_specific_vol, EOS_type, EOS_domain +use MOM_file_parser, only : log_version +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 implicit none ; private @@ -262,7 +263,7 @@ end subroutine find_eta_2d !> Calculate derived thermodynamic quantities for re-use later. -subroutine calc_derived_thermo(tv, h, G, GV, US, halo) +subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) 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 @@ -271,13 +272,16 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo) !! which will be set here. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - integer, optional, intent(in) :: halo !< Width of halo within which to + integer, optional, intent(in) :: halo !< Width of halo within which to !! calculate thicknesses + logical, optional, intent(in) :: debug !< If present and true, write debugging checksums ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: p_t ! Hydrostatic pressure atop a layer [R L2 T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G)) :: dp ! Pressure change across a layer [R L2 T-2 ~> Pa] + logical :: do_debug ! If true, write checksums for debugging. integer :: i, j, k, is, ie, js, je, halos, nz + do_debug = .false. ; if (present(debug)) do_debug = debug halos = 0 ; if (present(halo)) halos = max(0,halo) is = G%isc-halos ; ie = G%iec+halos ; js = G%jsc-halos ; je = G%jec+halos ; nz = GV%ke @@ -296,6 +300,15 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo) p_t(i,j) = p_t(i,j) + dp(i,j) enddo ; enddo ; endif enddo + tv%valid_SpV_halo = halos + + if (do_debug) then + call hchksum(h, "derived_thermo h", G%HI, haloshift=halos, scale=GV%H_to_MKS) + if (associated(tv%p_surf)) call hchksum(tv%p_surf, "derived_thermo p_surf", G%HI, & + haloshift=halos, scale=US%RL2_T2_to_Pa) + call hchksum(tv%T, "derived_thermo T", G%HI, haloshift=halos, scale=US%C_to_degC) + call hchksum(tv%S, "derived_thermo S", G%HI, haloshift=halos, scale=US%S_to_ppt) + endif endif end subroutine calc_derived_thermo @@ -493,12 +506,23 @@ subroutine thickness_to_dz_3d(h, tv, dz, G, GV, US, halo_size) integer, optional, intent(in) :: halo_size !< Width of halo within which to !! calculate thicknesses ! Local variables + character(len=128) :: mesg ! A string for error messages integer :: i, j, k, is, ie, js, je, halo, nz halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "thickness_to_dz called in fully non-Boussinesq mode with "//trim(mesg)) + endif + do k=1,nz ; do j=js,je ; do i=is,ie dz(i,j,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) enddo ; enddo ; enddo @@ -529,12 +553,23 @@ subroutine thickness_to_dz_jslice(h, tv, dz, j, G, GV, halo_size) integer, optional, intent(in) :: halo_size !< Width of halo within which to !! calculate thicknesses ! Local variables + character(len=128) :: mesg ! A string for error messages integer :: i, k, is, ie, halo, nz halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) is = G%isc-halo ; ie = G%iec+halo ; nz = GV%ke if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "thickness_to_dz called in fully non-Boussinesq mode with "//trim(mesg)) + endif + do k=1,nz ; do i=is,ie dz(i,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) enddo ; enddo diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index bec93376af..0c4a42e8c6 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -95,6 +95,8 @@ module MOM_variables real :: min_salinity !< The minimum value of salinity when BOUND_SALINITY=True [S ~> ppt]. real, allocatable, dimension(:,:,:) :: SpV_avg !< The layer averaged in situ specific volume [R-1 ~> m3 kg-1]. + integer :: valid_SpV_halo = -1 !< If positive, the valid halo size for SpV_avg, or if negative + !! SpV_avg is not currently set. ! These arrays are accumulated fluxes for communication with other components. real, dimension(:,:), pointer :: frazil => NULL() diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 0577a12ac5..dcce81ef73 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -364,6 +364,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C ! Remap all variables from the old grid h_new onto the new grid h_post_remap call ALE_remap_tracers(CS%ALE_CSp, G, GV, h_new, h_post_remap, CS%tracer_Reg, & CS%debug, dt=CS%dt_offline) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 h_new(i,j,k) = h_post_remap(i,j,k) From b1210a08dbb84b4917c836c08b6c3a003e754b77 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 27 Jun 2023 06:09:12 -0400 Subject: [PATCH 005/146] (*)+Use RHO_KV_CONVERT to set nonBous GV%H_to_m Use RHO_KV_CONVERT instead of RHO_0 to set the non-Boussinesq version of GV%m_to_H, so that there is a mechanism for testing the independence of the fully non-Boussinesq mode from the Boussinesq reference density. With this change, GV%Z_to_H is not guaranteed to be equal to (GV%Z_to_m*GV%m_to_H), with the latter expression preferred when setting parameters. By default the two parameters are the same, and they will probably only ever differ in testing the code. All Boussinesq solutions are bitwise identical, but there are differences in the description of RHO_KV_CONVERT that will appear in MOM_parameter_doc files. --- src/core/MOM_verticalGrid.F90 | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 5e9b5c476c..b0b9fa9fcd 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -138,8 +138,12 @@ subroutine verticalGridInit( param_file, GV, US ) default=.true., do_not_log=GV%Boussinesq) if (GV%Boussinesq) GV%semi_Boussinesq = .true. call get_param(param_file, mdl, "RHO_KV_CONVERT", Rho_Kv, & - "The density used to convert input kinematic viscosities into dynamic "//& - "viscosities in non-BOUSSINESQ mode, and similarly for vertical diffusivities.", & + "The density used to convert input vertical distances into thickesses in "//& + "non-BOUSSINESQ mode, and to convert kinematic viscosities into dynamic "//& + "viscosities and similarly for vertical diffusivities. GV%m_to_H is set "//& + "using this value, whereas GV%Z_to_H is set using RHO_0. The default is "//& + "RHO_0, but this can be set separately to demonstrate the independence of the "//& + "non-Boussinesq solutions of the value of RHO_0.", & units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & do_not_log=GV%Boussinesq) call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_Z, & @@ -186,18 +190,22 @@ subroutine verticalGridInit( param_file, GV, US ) GV%m_to_H = 1.0 / GV%H_to_m GV%H_to_MKS = GV%H_to_m GV%m2_s_to_HZ_T = GV%m_to_H * US%m_to_Z * US%T_to_s + + GV%H_to_Z = GV%H_to_m * US%m_to_Z + GV%Z_to_H = US%Z_to_m * GV%m_to_H else GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 - GV%m_to_H = US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H - GV%H_to_m = GV%H_to_kg_m2 / (US%R_to_kg_m3*GV%Rho0) + ! GV%m_to_H = US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H + GV%m_to_H = US%R_to_kg_m3*rho_Kv * GV%kg_m2_to_H GV%H_to_MKS = GV%H_to_kg_m2 GV%m2_s_to_HZ_T = US%R_to_kg_m3*rho_Kv * GV%kg_m2_to_H * US%m_to_Z * US%T_to_s - endif + GV%H_to_m = 1.0 / GV%m_to_H - GV%H_to_Z = GV%H_to_m * US%m_to_Z - GV%Z_to_H = US%Z_to_m * GV%m_to_H + GV%H_to_Z = US%m_to_Z * ( GV%H_to_kg_m2 / (US%R_to_kg_m3*GV%Rho0) ) + GV%Z_to_H = US%Z_to_m * ( US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H ) + endif - GV%Angstrom_H = GV%Z_to_H * GV%Angstrom_Z + GV%Angstrom_H = (US%Z_to_m * GV%m_to_H) * GV%Angstrom_Z GV%Angstrom_m = US%Z_to_m * GV%Angstrom_Z GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H, GV%m_to_H*1e-17) From 2342a5825b1d82f0d536c78796812411c7d591c9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 12 Jul 2023 16:35:50 -0400 Subject: [PATCH 006/146] +Add new (not yet used) arguments to 7 routines Add new arguments to 7 routines that will be needed for the non-Boussinesq capability, but do not use them yet, so that there will be fewer cross file dependencies as the various changes are being reviewed simultaneously. The impacted interfaces are MEKE_int, vertvisc_coef, sumSWoverBands, KPP_calculate, differential_diffuse_T_S, set_BBL_TKE, and apply_sponge In the three step_MOM_dyn_... routines and in calculateBuoyancyFlux1d, this change includes calls to thickness_to_dz to calculate the new vertical distance arrays that will be passed into vertvisc_coef or sumSWoverBands. The only place where the new arguments are actually used is in sumSWoverBands and set_opacity where the changes are particularly simple. All answers are bitwise identical, but there are new non-optional arguments to seven publicly visible routines. --- src/core/MOM.F90 | 2 +- src/core/MOM_dynamics_split_RK2.F90 | 12 ++++++---- src/core/MOM_dynamics_unsplit.F90 | 12 ++++++---- src/core/MOM_dynamics_unsplit_RK2.F90 | 10 ++++++--- src/core/MOM_forcing_type.F90 | 5 ++++- src/parameterizations/lateral/MOM_MEKE.F90 | 7 +++--- .../vertical/MOM_CVMix_KPP.F90 | 3 ++- .../vertical/MOM_diabatic_aux.F90 | 10 ++++++--- .../vertical/MOM_diabatic_driver.F90 | 22 +++++++++---------- .../vertical/MOM_opacity.F90 | 10 +++++---- .../vertical/MOM_set_diffusivity.F90 | 3 ++- src/parameterizations/vertical/MOM_sponge.F90 | 17 ++++++++------ .../vertical/MOM_vert_friction.F90 | 6 ++++- 13 files changed, 75 insertions(+), 44 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 703514fc52..df3a308e85 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3002,7 +3002,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call cpu_clock_end(id_clock_MOM_init) if (CS%use_dbclient) call database_comms_init(param_file, CS%dbcomms_CS) - CS%useMEKE = MEKE_init(Time, G, US, param_file, diag, CS%dbcomms_CS, CS%MEKE_CSp, CS%MEKE, & + CS%useMEKE = MEKE_init(Time, G, GV, US, param_file, diag, CS%dbcomms_CS, CS%MEKE_CSp, CS%MEKE, & restart_CSp, CS%MEKE_in_dynamics) call VarMix_init(Time, G, GV, US, param_file, diag, CS%VarMix) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 9fb1a6b356..5ce9ec8962 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -50,7 +50,7 @@ module MOM_dynamics_split_RK2 use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS use MOM_hor_visc, only : hor_visc_init, hor_visc_end -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds @@ -322,6 +322,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_bc_accel ! The summed zonal baroclinic accelerations @@ -567,7 +568,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif - call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2)") @@ -659,7 +661,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif - call vertvisc_coef(up, vp, h, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, & + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & CS%OBC, VarMix) call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) @@ -880,7 +883,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! u <- u + dt d/dz visc d/dz u ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (G%nonblocking_updates) then diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index e6f99cc9d8..80f7853744 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -79,7 +79,7 @@ module MOM_dynamics_unsplit use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type @@ -223,6 +223,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av, hp ! Predicted or averaged layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up, upp ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp, vpp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] @@ -345,7 +346,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call disable_averaging(CS%diag) dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt_pred - call vertvisc_coef(up, vp, h_av, forces, visc, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt_visc, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -405,7 +407,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! upp <- upp + dt/2 d/dz visc d/dz upp call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(hp, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(upp, vpp, hp, dz, forces, visc, tv, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -489,7 +492,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! u <- u + dt d/dz visc d/dz u call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u, v, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u, v, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index fbf416d13d..d1afca51d9 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -78,6 +78,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS +use MOM_interface_heights, only : thickness_to_dz use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type @@ -234,6 +235,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av ! Averaged layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] @@ -341,7 +343,8 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call set_viscous_ML(u_in, v_in, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) - call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) @@ -392,10 +395,11 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n] <- up* + dt d/dz visc d/dz up ! u[n] <- u*[n] + dt d/dz visc d/dz u[n] call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) - call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc_coef(u_in, v_in, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u_in, v_in, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp,& G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) call cpu_clock_end(id_clock_vertvisc) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a59c33d525..4897771100 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -15,6 +15,7 @@ module MOM_forcing_type use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_opacity, only : sumSWoverBands, optics_type, extract_optics_slice, optics_nbands use MOM_spatial_means, only : global_area_integral, global_area_mean use MOM_spatial_means, only : global_area_mean_u, global_area_mean_v @@ -974,6 +975,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt real, dimension(SZI_(G)) :: netEvap ! net FW flux leaving ocean via evaporation ! [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G)) :: netHeat ! net temp flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(SZI_(G), SZK_(GV)) :: dz ! Layer thicknesses in depth units [Z ~> m] real, dimension(max(nsw,1), SZI_(G)) :: penSWbnd ! penetrating SW radiation by band ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(SZI_(G)) :: pressure ! pressure at the surface [R L2 T-2 ~> Pa] @@ -1013,7 +1015,8 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! Sum over bands and attenuate as a function of depth ! netPen is the netSW as a function of depth - call sumSWoverBands(G, GV, US, h(:,j,:), optics_nbands(optics), optics, j, 1.0, & + call thickness_to_dz(h, tv, dz, j, G, GV) + call sumSWoverBands(G, GV, US, h(:,j,:), dz, optics_nbands(optics), optics, j, 1.0, & H_limit_fluxes, .true., penSWbnd, netPen) ! Density derivatives diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 6a439dfd22..02338fab96 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1088,12 +1088,13 @@ end subroutine MEKE_lengthScales_0d !> Initializes the MOM_MEKE module and reads parameters. !! Returns True if module is to be used, otherwise returns False. -logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, restart_CS, meke_in_dynamics) +logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, MEKE, restart_CS, meke_in_dynamics) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. - type(dbcomms_CS_type), intent(in) :: dbcomms_CS !< Database communications control structure + type(dbcomms_CS_type), intent(in) :: dbcomms_CS !< Database communications control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. type(MEKE_CS), intent(inout) :: CS !< MEKE control structure. type(MEKE_type), intent(inout) :: MEKE !< MEKE fields @@ -1102,7 +1103,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, !! otherwise in tracer dynamics ! Local variables - real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value [T ~> s] + real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value [T ~> s] real :: cdrag ! The default bottom drag coefficient [nondim]. character(len=200) :: eke_filename, eke_varname, inputdir character(len=16) :: eke_source_str diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 0127f8c556..32946021be 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -596,7 +596,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) end function KPP_init !> KPP vertical diffusivity/viscosity and non-local tracer transport -subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & +subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) ! Arguments @@ -605,6 +605,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 3096fe72cd..ba265af5e2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -224,7 +224,7 @@ end subroutine make_frazil !> This subroutine applies double diffusion to T & S, assuming no diapycnal mass !! fluxes, using a simple tridiagonal solver. -subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) +subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -234,13 +234,15 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: S !< Salinity [PSU] or [gSalt/kg], generically [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: Kd_T !< The extra diffusivity of temperature due to + intent(in) :: Kd_T !< The extra diffusivity of temperature due to !! double diffusion relative to the diffusivity of !! diffusivity of density [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: Kd_S !< The extra diffusivity of salinity due to !! double diffusion relative to the diffusivity of !! diffusivity of density [Z2 T-1 ~> m2 s-1]. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. real, intent(in) :: dt !< Time increment [T ~> s]. ! local variables @@ -1555,7 +1557,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! netPen_rate is the netSW as a function of depth, but only the surface value is used here, ! in which case the values of dt, h, optics and H_limit_fluxes are irrelevant. Consider ! writing a shorter and simpler variant to handle this very limited case. - ! call sumSWoverBands(G, GV, US, h2d(:,:), optics_nbands(optics), optics, j, dt, & + ! Find the vertical distances across layers. + ! call thickness_to_dz(h, tv, dz, j, G, GV) + ! call sumSWoverBands(G, GV, US, h2d, dz, optics_nbands(optics), optics, j, dt, & ! H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1bc29ee16f..0c28c063ea 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -351,7 +351,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call diapyc_energy_req_test(h, dt, tv, G, GV, US, CS%diapyc_en_rec_CSp) call cpu_clock_begin(id_clock_set_diffusivity) - call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS%set_diff_CSp, OBC=OBC) + call set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS%set_diff_CSp, OBC=OBC) call cpu_clock_end(id_clock_set_diffusivity) ! Frazil formation keeps the temperature above the freezing point. @@ -679,13 +679,13 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -751,7 +751,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (CS%double_diffuse .and. associated(tv%T)) then call cpu_clock_begin(id_clock_differential_diff) - call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, dt, G, GV) + call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, tv, dt, G, GV) call cpu_clock_end(id_clock_differential_diff) if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") @@ -1281,13 +1281,13 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -1889,13 +1889,13 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -1973,7 +1973,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (CS%double_diffuse .and. associated(tv%T)) then call cpu_clock_begin(id_clock_differential_diff) - call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, dt, G, GV) + call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, tv, dt, G, GV) call cpu_clock_end(id_clock_differential_diff) if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G, GV, US) @@ -2398,9 +2398,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & tv%eqn_of_state, EOSdom) enddo - call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) + call apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else - call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp) + call apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS%sponge_CSp) endif call cpu_clock_end(id_clock_sponge) if (CS%debug) then diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 77de5d13cd..a8029d031f 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -128,13 +128,13 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ ! Make sure there is no division by 0. inv_sw_pen_scale = 1.0 / max(CS%pen_sw_scale, 0.1*GV%Angstrom_Z, & - GV%H_to_Z*GV%H_subroundoff) + GV%dZ_subroundoff) if ( CS%Opacity_scheme == DOUBLE_EXP ) then !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie optics%opacity_band(1,i,j,k) = inv_sw_pen_scale optics%opacity_band(2,i,j,k) = 1.0 / max(CS%pen_sw_scale_2nd, & - 0.1*GV%Angstrom_Z, GV%H_to_Z*GV%H_subroundoff) + 0.1*GV%Angstrom_Z, GV%dZ_subroundoff) enddo ; enddo ; enddo if (.not.associated(sw_total) .or. (CS%pen_SW_scale <= 0.0)) then !$OMP parallel do default(shared) @@ -793,13 +793,15 @@ end subroutine absorbRemainingSW !> This subroutine calculates the total shortwave heat flux integrated over !! bands as a function of depth. This routine is only called for computing !! buoyancy fluxes for use in KPP. This routine does not update the state. -subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & +subroutine sumSWoverBands(G, GV, US, h, dz, nsw, optics, j, dt, & H_limit_fluxes, absorbAllSW, iPen_SW_bnd, netPen) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Layer vertical extent [Z ~> m]. integer, intent(in) :: nsw !< The number of bands of penetrating shortwave !! radiation, perhaps from optics_nbands(optics), type(optics_type), intent(in) :: optics !< An optics structure that has values @@ -877,7 +879,7 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & if (h(i,k) > 0.0) then do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then ! SW_trans is the SW that is transmitted THROUGH the layer - opt_depth = h(i,k)*GV%H_to_Z * optics%opacity_band(n,i,j,k) + opt_depth = dz(i,k) * optics%opacity_band(n,i,j,k) exp_OD = exp(-opt_depth) SW_trans = exp_OD diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 0dec7a40c0..9dc7b81c46 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1656,7 +1656,7 @@ end subroutine add_MLrad_diffusivity !> This subroutine calculates several properties related to bottom !! boundary layer turbulence. -subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) +subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1666,6 +1666,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure with pointers to thermodynamic fields type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes type(vertvisc_type), intent(inout) :: visc !< Structure containing vertical viscosities, bottom !! boundary layer properties and related fields. diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 0ef732a024..fce1eb493d 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -3,16 +3,17 @@ module MOM_sponge ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : sum_across_PEs +use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type use MOM_spatial_means, only : global_i_mean -use MOM_time_manager, only : time_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_verticalGrid, only : verticalGrid_type +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type ! Planned extension: Support for time varying sponge targets. @@ -301,12 +302,14 @@ end subroutine set_up_sponge_ML_density !> This subroutine applies damping to the layers thicknesses, mixed layer buoyancy, and a variety of !! tracers for every column where there is damping. -subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) +subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< An array to which the amount of fluid entrained diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 80fff62f21..0ab283a90e 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -938,7 +938,7 @@ end subroutine vertvisc_remnant !> Calculate the coupling coefficients (CS%a_u, CS%a_v, CS%a_u_gl90, CS%a_v_gl90) !! and effective layer thicknesses (CS%h_u and CS%h_v) for later use in the !! applying the implicit vertical viscosity via vertvisc(). -subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) +subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, VarMix) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -948,8 +948,12 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Vertical distance across layers [Z ~> m] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. real, intent(in) :: dt !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure From df0eaf0c608d40c8ef45adc91991490bfc21111e Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Wed, 19 Jul 2023 21:15:57 -0400 Subject: [PATCH 007/146] Fms2 io read3d slice (#399) * Restore functionality for reading slices from 3d volumes in MOM_io - The recent MOM_io modifications in support of FMS2_io accidentally removed support for reading on-grid data (same horizontal grid as model) k-slices. This is needed in some configurations in the model state initialization. * Add FMS1 interfaces * Additional patches to enable reading ongrid state initialization data - read local 3d volume rather than attempting to slice ongrid data vertically. - Related bugfixes in MOM_io --- config_src/infra/FMS1/MOM_coms_infra.F90 | 24 ++- config_src/infra/FMS1/MOM_io_infra.F90 | 41 +++++- config_src/infra/FMS2/MOM_coms_infra.F90 | 23 ++- config_src/infra/FMS2/MOM_io_infra.F90 | 70 ++++++++- src/framework/MOM_horizontal_regridding.F90 | 20 ++- src/framework/MOM_io.F90 | 154 +++++++++++++++++++- 6 files changed, 322 insertions(+), 10 deletions(-) diff --git a/config_src/infra/FMS1/MOM_coms_infra.F90 b/config_src/infra/FMS1/MOM_coms_infra.F90 index 939161875e..13f8006184 100644 --- a/config_src/infra/FMS1/MOM_coms_infra.F90 +++ b/config_src/infra/FMS1/MOM_coms_infra.F90 @@ -25,7 +25,7 @@ module MOM_coms_infra !> Communicate an array, string or scalar from one PE to others interface broadcast module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D - module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D, broadcast_real3D end interface broadcast !> Compute a checksum for a field distributed over a PE list. If no PE list is @@ -260,6 +260,28 @@ subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) end subroutine broadcast_real2D + +!> Communicate a 3-D array of reals from one PE to others +subroutine broadcast_real3D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real3D + ! field_chksum wrappers !> Compute a checksum for a field distributed over a PE list. If no PE list is diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index c0ccfcbcc8..e37e5db3cb 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -57,7 +57,7 @@ module MOM_io_infra !> Read a data field from a file interface read_field module procedure read_field_4d - module procedure read_field_3d + module procedure read_field_3d, read_field_3d_region module procedure read_field_2d, read_field_2d_region module procedure read_field_1d, read_field_1d_int module procedure read_field_0d, read_field_0d_int @@ -696,6 +696,45 @@ subroutine read_field_3d(filename, fieldname, data, MOM_Domain, & endif ; endif end subroutine read_field_3d +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 3-D data field named "fieldname" from file "filename". +subroutine read_field_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + if (present(MOM_Domain)) then + call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & + no_domain=no_domain) + else + call read_data(filename, fieldname, data, start, nread, no_domain=no_domain) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:,:) = scale*data(:,:,:) + endif + endif ; endif +end subroutine read_field_3d_region + + !> This routine uses the fms_io subroutine read_data to read a distributed !! 4-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90 index 939161875e..cf9a724734 100644 --- a/config_src/infra/FMS2/MOM_coms_infra.F90 +++ b/config_src/infra/FMS2/MOM_coms_infra.F90 @@ -25,7 +25,7 @@ module MOM_coms_infra !> Communicate an array, string or scalar from one PE to others interface broadcast module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D - module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D, broadcast_real3D end interface broadcast !> Compute a checksum for a field distributed over a PE list. If no PE list is @@ -260,6 +260,27 @@ subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) end subroutine broadcast_real2D +!> Communicate a 3-D array of reals from one PE to others +subroutine broadcast_real3D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real3D + ! field_chksum wrappers !> Compute a checksum for a field distributed over a PE list. If no PE list is diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 99d0ac3345..a43b4e9344 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -66,7 +66,7 @@ module MOM_io_infra !> Read a data field from a file interface read_field module procedure read_field_4d - module procedure read_field_3d + module procedure read_field_3d, read_field_3d_region module procedure read_field_2d, read_field_2d_region module procedure read_field_1d, read_field_1d_int module procedure read_field_0d, read_field_0d_int @@ -1030,6 +1030,74 @@ subroutine read_field_3d(filename, fieldname, data, MOM_Domain, & end subroutine read_field_3d +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 3-D data field named "fieldname" from file "filename". +subroutine read_field_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 3 + !! dimensions. For this 3-d read, the + !! 4th value is always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain)) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "read_field_2d_region: ", & + filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj_DD, var_to_read, data, corner=start(1:3), edge_lengths=nread(1:3)) + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + else + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_2d_region: ", filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj, var_to_read, data, corner=start(1:3), edge_lengths=nread(1:3)) + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:,:) = scale*data(:,:,:) + endif + endif ; endif + +end subroutine read_field_3d_region + !> This routine uses the fms_io subroutine read_data to read a distributed !! 4-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 883653d715..34d0b73cb9 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -309,6 +309,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its !! native horizontal grid, with units that change !! as the input data is interpreted [a] then [A ~> a] + real, dimension(:,:,:), allocatable :: tr_in_full !< A 3-d array for holding input data on the + !! model horizontal grid, with units that change + !! as the input data is interpreted [a] then [A ~> a] real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles !! with units that change as the input data is !! interpreted [a] then [A ~> a] @@ -448,6 +451,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr if (is_ongrid) then allocate(tr_in(is:ie,js:je), source=0.0) + allocate(tr_in_full(is:ie,js:je,kd), source=0.0) allocate(mask_in(is:ie,js:je), source=0.0) else call horizontal_interp_init() @@ -470,14 +474,19 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr ! Loop through each data level and interpolate to model grid. ! After interpolating, fill in points which will be needed to define the layers. + + if (is_ongrid) then + start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = 1 + count(1) = ie-is+1 ; count(2) = je-js+1 ; count(3) = kd ; start(4) = 1 ; count(4) = 1 + call MOM_read_data(trim(filename), trim(varnam), tr_in_full, start, count, G%Domain) + endif + do k=1,kd mask_in(:,:) = 0.0 tr_out(:,:) = 0.0 if (is_ongrid) then - start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = k - count(1) = ie-is+1 ; count(2) = je-js+1 ; count(3) = 1 ; start(4) = 1 ; count(4) = 1 - call MOM_read_data(trim(filename), trim(varnam), tr_in, start, count, G%Domain) + tr_in(is:ie,js:je) = tr_in_full(is:ie,js:je,k) do j=js,je do i=is,ie if (abs(tr_in(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then @@ -594,7 +603,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr enddo ! kd - deallocate(lon_in, lat_in) + if (allocated(lat_inp)) deallocate(lat_inp) + deallocate(tr_in) + if (allocated(tr_inp)) deallocate(tr_inp) + if (allocated(tr_in_full)) deallocate(tr_in_full) end subroutine horiz_interp_and_extrap_tracer_record diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index bebce6f502..220a7d6bcf 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -100,6 +100,7 @@ module MOM_io module procedure MOM_read_data_2d module procedure MOM_read_data_2d_region module procedure MOM_read_data_3d + module procedure MOM_read_data_3d_region module procedure MOM_read_data_4d end interface MOM_read_data @@ -137,7 +138,7 @@ module MOM_io interface read_variable module procedure read_variable_0d, read_variable_0d_int module procedure read_variable_1d, read_variable_1d_int - module procedure read_variable_2d + module procedure read_variable_2d, read_variable_3d end interface read_variable !> Read a global or variable attribute from a named netCDF file using netCDF calls @@ -1161,7 +1162,7 @@ subroutine read_variable_2d(filename, varname, var, start, nread, ncid_in) allocate(field_nread(field_ndims)) field_nread(:2) = field_shape(:2) field_nread(3:) = 1 - if (present(nread)) field_shape(:2) = nread(:2) + if (present(nread)) field_nread(:2) = nread(:2) rc = nf90_get_var(ncid, varid, var, field_start, field_nread) @@ -1182,6 +1183,119 @@ subroutine read_variable_2d(filename, varname, var, start, nread, ncid_in) call broadcast(var, size(var), blocking=.true.) end subroutine read_variable_2d + +subroutine read_variable_3d(filename, varname, var, start, nread, ncid_in) + character(len=*), intent(in) :: filename !< Name of file to be read + character(len=*), intent(in) :: varname !< Name of variable to be read + real, intent(out) :: var(:,:,:) !< Output array of variable [arbitrary] + integer, optional, intent(in) :: start(:) !< Starting index on each axis. + integer, optional, intent(in) :: nread(:) !< Number of values to be read along each axis + integer, optional, intent(in) :: ncid_in !< netCDF ID of an opened file. + !! If absent, the file is opened and closed within this routine. + + integer :: ncid, varid + integer :: field_ndims, dim_len + integer, allocatable :: field_dimids(:), field_shape(:) + integer, allocatable :: field_start(:), field_nread(:) + integer :: i, rc + character(len=*), parameter :: hdr = "read_variable_3d: " + + ! Validate shape of start and nread + if (present(start)) then + if (size(start) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start must have at least two dimensions.") + endif + + if (present(nread)) then + if (size(nread) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread must have at least two dimensions.") + + if (any(nread(3:) > 1)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread may only read a single level in higher dimensions.") + endif + + ! Since start and nread may be reshaped, we cannot rely on netCDF to ensure + ! that their lengths are equivalent, and must do it here. + if (present(start) .and. present(nread)) then + if (size(start) /= size(nread)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start and nread must have the same length.") + endif + + ! Open and read `varname` from `filename` + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_Read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + + ! Query for the dimensionality of the input field + rc = nf90_inquire_variable(ncid, varid, ndims=field_ndims) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + ! Confirm that field is at least 2d + if (field_ndims < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) // " " // & + trim(varname) // " from " // trim(filename) // " is not a 2D field.") + + ! If start and nread are present, then reshape them to match field dims + if (present(start) .or. present(nread)) then + allocate(field_shape(field_ndims)) + allocate(field_dimids(field_ndims)) + + rc = nf90_inquire_variable(ncid, varid, dimids=field_dimids) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + do i = 1, field_ndims + rc = nf90_inquire_dimension(ncid, field_dimids(i), len=dim_len) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // ": Difficulties reading dimensions from " // trim(filename)) + field_shape(i) = dim_len + enddo + + ! Reshape start(:) and nreads(:) in case ranks differ + allocate(field_start(field_ndims)) + field_start(:) = 1 + if (present(start)) then + dim_len = min(size(start), size(field_start)) + field_start(:dim_len) = start(:dim_len) + endif + + allocate(field_nread(field_ndims)) + field_nread(:3) = field_shape(:3) + !field_nread(3:) = 1 + if (present(nread)) field_nread(:3) = nread(:3) + + rc = nf90_get_var(ncid, varid, var, field_start, field_nread) + + deallocate(field_start) + deallocate(field_nread) + deallocate(field_shape) + deallocate(field_dimids) + else + rc = nf90_get_var(ncid, varid, var) + endif + + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_3d + !> Read a character-string global or variable attribute subroutine read_attribute_str(filename, attname, att_val, varname, found, all_read, ncid_in) character(len=*), intent(in) :: filename !< Name of the file to read @@ -2198,6 +2312,42 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & endif end subroutine MOM_read_data_3d +!> Read a 3d region array from file using infrastructure I/O. +subroutine MOM_read_data_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale, turns) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, dimension(:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + integer, dimension(:), intent(in) :: start !< Starting index for each axis. + integer, dimension(:), intent(in) :: nread !< Number of values to read along each axis. + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition + logical, optional, intent(in) :: no_domain !< If true, field does not use + !! domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + integer, optional, intent(in) :: turns !< Number of quarter turns from + !! input to model grid + + integer :: qturns ! Number of quarter turns + real, allocatable :: data_in(:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call read_field(filename, fieldname, data, start, nread, & + MOM_Domain=MOM_Domain, no_domain=no_domain, scale=scale & + ) + else + call allocate_rotated_array(data, [1,1,1], -qturns, data_in) + call read_field(filename, fieldname, data_in, start, nread, & + MOM_Domain=MOM_Domain%domain_in, no_domain=no_domain, scale=scale & + ) + call rotate_array(data_in, qturns, data) + deallocate(data_in) + endif +end subroutine MOM_read_data_3d_region !> Read a 4d array from file using infrastructure I/O. subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & From 25feaf2ce017c087a06980ee8106f17f1ea605f2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 18 Jul 2023 09:44:17 -0400 Subject: [PATCH 008/146] Fix logic for setting KV_ML_INVZ2 from KVML - We were reading KV_ML_INVZ2 without logging, then checking for KVML and finally logging based on a combination of the two. This had the side affect that we get warnings about not using KVML even if KVML was not present. - The fix checks for KVML first, and then changes the default so that when KVML=1e-4 is replaced by KV_ML_INVZ2=1e-4 we end up with no warnings and KVML can be obsoleted safely. Note: this commit alone does not remove all warnings from the MOM6-examples suite because we still need to fix the MOM_input that still use KVML - KVML needs to be unscaled since it is the default for KV_ML_INVZ2 - tc3 used KVML and has been corrected. --- .testing/tc3/MOM_input | 8 +++--- .../vertical/MOM_vert_friction.F90 | 25 +++++++------------ 2 files changed, 13 insertions(+), 20 deletions(-) diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index a034960d1e..6963feee98 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -283,10 +283,10 @@ HMIX_FIXED = 20.0 ! [m] KV = 1.0E-04 ! [m2 s-1] ! The background kinematic viscosity in the interior. ! The molecular value, ~1e-6 m2 s-1, may be used. -KVML = 0.01 ! [m2 s-1] default = 1.0E-04 - ! The kinematic viscosity in the mixed layer. A typical - ! value is ~1e-2 m2 s-1. KVML is not used if - ! BULKMIXEDLAYER is true. The default is set by KV. +KV_ML_INVZ2 = 0.01 ! [m2 s-1] default = 0.0 + ! An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, with + ! the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the distance + ! from the surface, to allow for finite wind stresses to be transmitted through. HBBL = 10.0 ! [m] ! The thickness of a bottom boundary layer with a ! viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 0ab283a90e..496012c3d9 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2156,6 +2156,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & # include "version_variable.h" character(len=40) :: mdl = "MOM_vert_friction" ! This module's name. character(len=40) :: thickness_units + real :: Kv_mks ! KVML in MKS if (associated(CS)) then call MOM_error(WARNING, "vertvisc_init called with an associated "// & @@ -2339,30 +2340,22 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%Kvml_invZ2 = 0.0 if (GV%nkml < 1) then - call get_param(param_file, mdl, "KV_ML_INVZ2", CS%Kvml_invZ2, & - "An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, "//& - "with the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the "//& - "distance from the surface, to allow for finite wind stresses to be "//& - "transmitted through infinitesimally thin surface layers. This is an "//& - "older option for numerical convenience without a strong physical basis, "//& - "and its use is now discouraged.", & - units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T, do_not_log=.true.) - if (CS%Kvml_invZ2 < 0.0) then - call get_param(param_file, mdl, "KVML", CS%Kvml_invZ2, & + call get_param(param_file, mdl, "KVML", Kv_mks, & "The scale for an extra kinematic viscosity in the mixed layer", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T, do_not_log=.true.) - if (CS%Kvml_invZ2 >= 0.0) & - call MOM_error(WARNING, "KVML is a deprecated parameter. Use KV_ML_INVZ2 instead.") + units="m2 s-1", default=-1.0, do_not_log=.true.) + if (Kv_mks >= 0.0) then + call MOM_error(WARNING, "KVML is a deprecated parameter. Use KV_ML_INVZ2 instead.") + else + Kv_mks = 0.0 endif - if (CS%Kvml_invZ2 < 0.0) CS%Kvml_invZ2 = 0.0 - call log_param(param_file, mdl, "KV_ML_INVZ2", CS%Kvml_invZ2, & + call get_param(param_file, mdl, "KV_ML_INVZ2", CS%Kvml_invZ2, & "An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, "//& "with the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the "//& "distance from the surface, to allow for finite wind stresses to be "//& "transmitted through infinitesimally thin surface layers. This is an "//& "older option for numerical convenience without a strong physical basis, "//& "and its use is now discouraged.", & - units="m2 s-1", default=0.0, unscale=US%Z2_T_to_m2_s) + units="m2 s-1", default=Kv_mks, scale=US%m2_s_to_Z2_T) endif if (.not.CS%bottomdraglaw) then From a5129ca3772d461b8bcb12b1aa23b2b942a734bd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 10:07:18 -0400 Subject: [PATCH 009/146] +Use RHO_PGF_REF for the pressure gradient forces Use the new runtime parameter RHO_PGF_REF instead of RHO_0 to set the reference density that is subtracted off from the other densities when calculating the finite volume pressure gradient forces. Although the answers are mathematically equivalent for any value of this parameter, a judicious choice can reduce the impacts of roundoff errors by about 2 orders of magnitude. By default, RHO_PGF_REF is set to RHO_0, and all answers are bitwise identical. However, there is a new runtime parameter that appears in many of the MOM_parameter_doc.all files. --- src/core/MOM_PressureForce_FV.F90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 14c9b2e6dc..281623ae84 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -519,7 +519,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff I_Rho0 = 1.0 / GV%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 rho_ref = CS%Rho0 @@ -827,12 +827,11 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS 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 "//& - "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, "RHO_PGF_REF", CS%Rho0, & + "The reference density that is subtracted off when calculating pressure "//& + "gradient forces. Its inverse is subtracted off of specific volumes when "//& + "in non-Boussinesq mode. The default is RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & From bb71c346ac4dc1d9c87f2d4e265ecfc1bed90403 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 20 Jul 2023 09:18:21 -0400 Subject: [PATCH 010/146] Converted warning about depth_list to a note The message that a file is being created was issued as a WARNING when we all agree it should really be a NOTE. Depth_list.nc is read if it is present to avoid recomputing a sorted list, but the absence of the file is not an error and does not warrant a warning. Changes: - Changed WARNING to NOTE. - Removed MOM_mesg from imports since it wasn't being used. --- src/diagnostics/MOM_sum_output.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index fd957d0a44..aae32a7862 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -8,7 +8,7 @@ module MOM_sum_output use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs, field_chksum use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, MOM_mesg +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type @@ -1077,7 +1077,7 @@ subroutine depth_list_setup(G, GV, US, DL, CS) valid_DL_read = .true. ! Otherwise there would have been a fatal error. endif else - if (is_root_pe()) call MOM_error(WARNING, "depth_list_setup: "// & + if (is_root_pe()) call MOM_error(NOTE, "depth_list_setup: "// & trim(CS%depth_list_file)//" does not exist. Creating a new file.") valid_DL_read = .false. endif From b9c7c8689707b0a4e6c9d1d95fa9c57fcd5202f6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 19 Jul 2023 09:32:28 -0400 Subject: [PATCH 011/146] Correct diagnostic coordinate interpolation scheme The interpolation scheme for state-dependent diagnostic coordinates was incorrectly registering as the same parameter as the main model. This meant it was never possible to change the interpolation scheme from the default (which was not the same as the main model). Fix registers the generated parameter name which was always computed but not used. A typical example of the generated parameter is "DIAG_COORD_INTERP_SCHEME_RHO2". --- src/ALE/MOM_regridding.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index c5f5807f66..4cc60d16b2 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -263,7 +263,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m param_name = create_coord_param(param_prefix, "INTERP_SCHEME", param_suffix) string2 = 'PPM_H4' ! Default for diagnostics endif - call get_param(param_file, mdl, "INTERPOLATION_SCHEME", string, & + call get_param(param_file, mdl, param_name, string, & "This sets the interpolation scheme to use to "//& "determine the new grid. These parameters are "//& "only relevant when REGRIDDING_COORDINATE_MODE is "//& From ccd3ded7b6279f433115e16f183cf29a1c38063e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 20 Jul 2023 07:23:09 -0400 Subject: [PATCH 012/146] +(*)Fix wave_speed_init mono_N2_depth bug Fixed a bug in which wave_speed_init was effectively discarding any values of mono_N2_depth passed to it via the optional argument mono_N2_depth, but also changed the default value of RESOLN_N2_FILTER_DEPTH, which was previously being discarded, to disable the monotonization and replicate the previous results. There were also clarifying additions made to the description how to disable RESOLN_N2_FILTER_DEPTH. This will change some entries in MOM_parameter_doc files, and it will change solutions in cases that set RESOLN_N2_FILTER_DEPTH to a non-default value and have parameter settings that use the resolution function to scale their horizontal mixing. There are, however, no known active simulations where the answers are expected to change. --- src/diagnostics/MOM_wave_speed.F90 | 4 +++- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 5 +++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index bb1b381c15..5757e25cd1 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -39,6 +39,7 @@ module MOM_wave_speed !! wave_speed() which can be overridden by optional arguments. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of !! calculating the equivalent barotropic wave speed [Z ~> m]. + !! If this parameter is negative, this limiting does not occur. !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. real :: min_speed2 = 0. !< The minimum mode 1 internal wave speed squared [L2 T-2 ~> m2 s-2] @@ -1465,7 +1466,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de call log_version(mdl, version) call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction, & - better_speed_est=better_speed_est, min_speed=min_speed, wave_speed_tol=wave_speed_tol, & + mono_N2_depth=mono_N2_depth, better_speed_est=better_speed_est, & + min_speed=min_speed, wave_speed_tol=wave_speed_tol, & remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date, & c1_thresh=c1_thresh) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 7d71a62e25..8f0aa02b12 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1239,8 +1239,9 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& - "artifacts from altering the equivalent barotropic mode structure.",& - units="m", default=2000., scale=US%m_to_Z) + "artifacts from altering the equivalent barotropic mode structure. "//& + "This monotonzization is disabled if this parameter is negative.", & + units="m", default=-1.0, scale=US%m_to_Z) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif From 6102be250c7ad59ffb3afe8816058a0d29f2cae7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 10:35:09 -0400 Subject: [PATCH 013/146] *+Revise non-Boussinesq gprime expressions Revised the calculation of gprime and the coordinate densities (GV%Rlay) in fully non-Boussinesq mode to use the arithmetic mean of adjacent coordinate densities in the denominator of the expression for g_prime in place of RHO_0. Also use LIGHTEST_DENSITY in place of RHO_0 to specify the top-level coordinate density in certain coordinate modes. Also made corresponding changes to the fully non-Boussinesq APE calculation when CALCULATE_APE is true, and eliminated an incorrect calculation of the layer volumes in non-Boussinesq mode using the Boussinesq reference density that was never actually being used when CALCULATE_APE is false. This commit will change answers in some fully non-Boussinesq calculations, and an existing runtime parameter is used and logged in some new cases, changing the MOM_parameter_doc file in those cases. --- src/diagnostics/MOM_sum_output.F90 | 38 +++++--- .../MOM_coord_initialization.F90 | 94 +++++++++++++++---- 2 files changed, 101 insertions(+), 31 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index aae32a7862..fb95b79a91 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -510,24 +510,18 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci do k=1,nz ; vol_lay(k) = (US%m_to_L**2*GV%H_to_Z/GV%H_to_kg_m2)*mass_lay(k) ; enddo else tmp1(:,:,:) = 0.0 - if (CS%do_APE_calc) then - do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) - enddo ; enddo ; enddo - mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) + do k=1,nz ; do j=js,je ; do i=is,ie + tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) + enddo ; enddo ; enddo + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) + if (CS%do_APE_calc) then call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = US%Z_to_m*US%L_to_m**2*(eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) enddo ; enddo ; enddo vol_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=vol_lay) do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2 * vol_lay(k) ; enddo - else - do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) - enddo ; enddo ; enddo - mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) - do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2*US%kg_m3_to_R * (mass_lay(k) / GV%Rho0) ; enddo endif endif ! Boussinesq @@ -643,7 +637,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci if (GV%Boussinesq) then do j=js,je ; do i=is,ie hbelow = 0.0 - do k=nz,1,-1 + do K=nz,1,-1 hbelow = hbelow + h(i,j,k) * GV%H_to_Z hint = Z_0APE(K) + (hbelow - (G%bathyT(i,j) + G%Z_ref)) hbot = Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref) @@ -652,14 +646,28 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci (hint * hint - hbot * hbot) enddo enddo ; enddo - else + elseif (GV%semi_Boussinesq) then do j=js,je ; do i=is,ie - do k=nz,1,-1 + do K=nz,1,-1 hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. hbot = max(Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref), 0.0) PE_pt(i,j,K) = (0.5 * PE_scale_factor * areaTm(i,j) * (GV%Rho0*GV%g_prime(K))) * & - (hint * hint - hbot * hbot) + (hint * hint - hbot * hbot) + enddo + enddo ; enddo + else + do j=js,je ; do i=is,ie + do K=nz,2,-1 + hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref), 0.0) + PE_pt(i,j,K) = (0.25 * PE_scale_factor * areaTm(i,j) * & + ((GV%Rlay(k)+GV%Rlay(k-1))*GV%g_prime(K))) * & + (hint * hint - hbot * hbot) enddo + hint = Z_0APE(1) + eta(i,j,1) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(1) - (G%bathyT(i,j) + G%Z_ref), 0.0) + PE_pt(i,j,1) = (0.5 * PE_scale_factor * areaTm(i,j) * (GV%Rlay(1)*GV%g_prime(1))) * & + (hint * hint - hbot * hbot) enddo ; enddo endif diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 8af8cd3bc6..37c719209b 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -126,6 +126,7 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) ! Local variables real :: g_int ! Reduced gravities across the internal interfaces [L2 Z-1 T-2 ~> m s-2]. real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref ! The target density of the surface layer [R ~> kg m-3]. character(len=40) :: mdl = "set_coord_from_gprime" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -138,11 +139,20 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GINT", g_int, & "The reduced gravity across internal interfaces.", & units="m s-2", fail_if_missing=.true., scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = g_int ; enddo - Rlay(1) = GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = Rlay_Ref + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif call callTree_leave(trim(mdl)//'()') @@ -184,9 +194,15 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) enddo ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs - do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) - enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_layer_density @@ -237,7 +253,13 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state) ! These statements set the layer densities. ! - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_ref @@ -294,7 +316,15 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, (/1,nz/) ) - do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_profile @@ -387,7 +417,15 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) enddo - do k=2,nz ; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_range @@ -429,7 +467,15 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) call MOM_read_data(filename, coord_var, Rlay, scale=US%kg_m3_to_R) g_prime(1) = g_fs - do k=2,nz ; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif do k=1,nz ; if (g_prime(k) <= 0.0) then call MOM_error(FATAL, "MOM_initialization set_coord_from_file: "//& "Zero or negative g_primes read from variable "//"Layer"//" in file "//& @@ -479,9 +525,15 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) enddo ! These statements set the interface reduced gravities. g_prime(1) = g_fs - do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) - enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_linear @@ -498,6 +550,7 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref ! The target density of the surface layer [R ~> kg m-3]. character(len=40) :: mdl = "set_coord_to_none" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -507,11 +560,20 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS" , g_fs, & "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = 0. ; enddo - Rlay(1) = GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = Rlay_Ref + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif call callTree_leave(trim(mdl)//'()') @@ -522,8 +584,8 @@ end subroutine set_coord_to_none subroutine write_vertgrid_file(GV, US, param_file, directory) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - character(len=*), intent(in) :: directory !< The directory into which to place the file. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + character(len=*), intent(in) :: directory !< The directory into which to place the file. ! Local variables character(len=240) :: filepath type(vardesc) :: vars(2) From 2f6e86e342608f07f5cc3fb478a22cc6089075b3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 21 Jul 2023 12:00:14 -0400 Subject: [PATCH 014/146] *Non-Boussinesq revision of MOM_thickness_diffuse Refactored thickness_diffuse when in non-Boussinesq mode to avoid any dependencies on the Boussinesq reference density, and to translate the volume streamfunction into the mass streamfunction using an appropriately defined in-situ density averaged to the interfaces at velocity points. This form follows the suggestions of Appendix A.3.2 of Griffies and Greatbatch (Ocean Modelling, 2012) when in non-Boussinesq mode. Thickness_diffuse_full was also revised to work properly in non-Boussinesq mode (and not depend on the Boussinesq reference density) when no equation of state is used. As a part of these changes, the code now uses thickness-based streamfunctions and other thickness-based internal calculations in MOM_thickness_diffuse. For example, the overturning streamfunctions with this change are now in m3/s in Boussinesq mode, but kg/s in non-Boussinesq mode. These changes use a call to thickness_to_dz to set up a separate variable with the vertical distance across layers, and in non-Boussinesq mode they use tv%SpV_avg to estimate in situ densities. Additional debugging checksums were added to thickness_diffuse. The code changes are extensive with 15 new or renamed internal variables, and changes to the units of 9 other internal variables and 3 arguments to the private routine streamfn_solver. After this change, GV%Rho, GV%Z_to_H and GV%H_to_Z are no longer used in any non-Boussinesq calculations (12 such instances having been elimated). Because some calculations have to be redone with the separate thickness and dz variables, this will be more expensive than the original version. No public interfaces are changed, and all answers are bitwise identical in Boussinesq or semiBoussinesq mode, but they will change in non-Boussinesq mode when the isopycnal height diffusion parameterization is used. --- .../lateral/MOM_thickness_diffuse.F90 | 286 ++++++++++++------ 1 file changed, 195 insertions(+), 91 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index a7ff2f1c0a..8617795e16 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -14,7 +14,7 @@ module MOM_thickness_diffuse use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : MOM_read_data, slasher -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_isopycnal_slopes, only : vert_fill_TS use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type @@ -439,7 +439,6 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif endif - !$OMP do do K=1,nz+1 ; do j=js,je ; do I=is-1,ie ; int_slope_u(I,j,K) = 0.0 ; enddo ; enddo ; enddo !$OMP do @@ -458,6 +457,12 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%debug) then call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + call uvchksum("Kh_[uv]_CFL", Kh_u_CFL, Kh_v_CFL, G%HI, haloshift=0, & + scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + if (Resoln_scaled) then + call uvchksum("Res_fn_[uv]", VarMix%Res_fn_u, VarMix%Res_fn_v, G%HI, haloshift=0, & + scale=1.0, scalar_pair=.true.) + endif call uvchksum("int_slope_[uv]", int_slope_u, int_slope_v, G%HI, haloshift=0) call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, scale=GV%H_to_m) call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, scale=US%Z_to_m) @@ -628,14 +633,17 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. h_frac ! The fraction of the mass in the column above the bottom ! interface of a layer that is within a layer [nondim]. 0 m] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & Slope_y_PE, & ! 3D array of neutral slopes at v-points, set equal to Slope (below) [nondim] hN2_y_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency - ! at v-points [L2 Z-1 T-2 ~> m s-2], used for calculating PE release + ! at v-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], + ! used for calculating the potential energy release real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below) [nondim] hN2_x_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency - ! at u-points [L2 Z-1 T-2 ~> m s-2], used for calculating PE release + ! at u-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], + ! used for calculating the potential energy release real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & pres, & ! The pressure at an interface [R L2 T-2 ~> Pa]. h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -670,8 +678,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: Work_v(SZI_(G),SZJB_(G)) ! The work done by the isopycnal height diffusion ! integrated over v-point water columns [R Z L4 T-3 ~> W] real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. - real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell [L4 Z-1 T-3 ~> m3 s-3] - ! The calculation is equal to h * S^2 * N^2 * kappa_GM. + real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell + ! [R Z L2 T-3 ~> W m-2]. The calculation equals rho0 * h * S^2 * N^2 * kappa_GM. real :: I4dt ! 1 / 4 dt [T-1 ~> s-1]. real :: drdiA, drdiB ! Along layer zonal potential density gradients in the layers above (A) ! and below (B) the interface times the grid spacing [R ~> kg m-3]. @@ -686,57 +694,71 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! [Z R ~> kg m-2]. real :: hg2A, hg2B, hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. - real :: dzaL, dzaR ! Temporary thicknesses [Z ~> m] + real :: dzg2A, dzg2B ! Squares of geometric mean vertical layer extents [Z2 ~> m2]. + real :: dzaA, dzaB ! Arithmetic mean vertical layer extents [Z ~> m]. + real :: dzaL, dzaR ! Temporary vertical layer extents [Z ~> m] real :: wtA, wtB ! Unnormalized weights of the slopes above and below [H3 ~> m3 or kg3 m-6] real :: wtL, wtR ! Unnormalized weights of the slopes to the left and right [H3 Z ~> m4 or kg3 m-5] real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. - real :: h_harm ! Harmonic mean layer thickness [H ~> m or kg m-2]. - real :: c2_h_u(SZIB_(G),SZK_(GV)+1) ! Wave speed squared divided by h at u-points [L2 Z-1 T-2 ~> m s-2]. - real :: c2_h_v(SZI_(G),SZK_(GV)+1) ! Wave speed squared divided by h at v-points [L2 Z-1 T-2 ~> m s-2]. - real :: hN2_u(SZIB_(G),SZK_(GV)+1) ! Thickness in m times N2 at interfaces above u-points [L2 Z-1 T-2 ~> m s-2]. - real :: hN2_v(SZI_(G),SZK_(GV)+1) ! Thickness in m times N2 at interfaces above v-points [L2 Z-1 T-2 ~> m s-2]. + real :: dz_harm ! Harmonic mean layer vertical extent [Z ~> m]. + real :: c2_dz_u(SZIB_(G),SZK_(GV)+1) ! Wave speed squared divided by dz at u-points times rescaling + ! factors from depths to thicknesses [H2 L2 Z-3 T-2 ~> m s-2 or kg m-2 s-2] + real :: c2_dz_v(SZI_(G),SZK_(GV)+1) ! Wave speed squared divided by dz at v-points times rescaling + ! factors from depths to thicknesses [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real :: dzN2_u(SZIB_(G),SZK_(GV)+1) ! Vertical extent times N2 at interfaces above u-points times + ! rescaling factors from vertical to horizontal distances [L2 Z-1 T-2 ~> m s-2] + real :: dzN2_v(SZI_(G),SZK_(GV)+1) ! Vertical extent times N2 at interfaces above v-points times + ! rescaling factors from vertical to horizontal distances [L2 Z-1 T-2 ~> m s-2] real :: Sfn_est ! A preliminary estimate (before limiting) of the overturning - ! streamfunction [Z L2 T-1 ~> m3 s-1]. - real :: Sfn_unlim_u(SZIB_(G),SZK_(GV)+1) ! Streamfunction for u-points [Z L2 T-1 ~> m3 s-1]. - real :: Sfn_unlim_v(SZI_(G),SZK_(GV)+1) ! Streamfunction for v-points [Z L2 T-1 ~> m3 s-1]. + ! streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: Sfn_unlim_u(SZIB_(G),SZK_(GV)+1) ! Volume streamfunction for u-points [Z L2 T-1 ~> m3 s-1] + real :: Sfn_unlim_v(SZI_(G),SZK_(GV)+1) ! Volume streamfunction for v-points [Z L2 T-1 ~> m3 s-1] real :: slope2_Ratio_u(SZIB_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] real :: slope2_Ratio_v(SZI_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] real :: Sfn_in_h ! The overturning streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] (note that ! the units are different from other Sfn vars). - real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface. This is a - ! good thing to use when the slope is so large as to be meaningless [Z L2 T-1 ~> m3 s-1]. + real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. This is a good value to use when the + ! slope is so large as to be meaningless, usually due to weak stratification. real :: Slope ! The slope of density surfaces, calculated in a way that is always ! between -1 and 1 after undoing dimensional scaling, [Z L-1 ~> nondim] real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. real :: I_slope_max2 ! The inverse of slope_max squared [L2 Z-2 ~> nondim]. 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 :: hn_2 ! Half of h_neglect [H ~> m or kg m-2]. real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. real :: dz_neglect ! A thickness [Z ~> m], that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: G_scale ! The gravitational acceleration times a unit conversion ! factor [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. logical :: find_work ! If true, find the change in energy due to the fluxes. integer :: nk_linear ! The number of layers over which the streamfunction goes to 0. real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. + real :: Rho_avg ! The in situ density averaged to an interface [R ~> kg m-3] real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [L2 Z-2 T-2 ~> s-2] + real :: N2_unlim ! An unlimited estimate of the buoyancy frequency + ! times unit conversion factors [L2 Z-2 T-2 ~> s-2] real :: Tl(5) ! copy of T in local stencil [C ~> degC] real :: mn_T ! mean of T in local stencil [C ~> degC] real :: mn_T2 ! mean of T**2 in local stencil [C2 ~> degC2] real :: hl(5) ! Copy of local stencil of H [H ~> m] real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] + real :: Z_to_H ! A conversion factor from heights to thicknesses, perhaps based on + ! a spatially variable local density [H Z-1 ~> nondim or kg m-3] real :: Tsgs2(SZI_(G),SZJ_(G),SZK_(GV)) ! Sub-grid temperature variance [C2 ~> degC2] real :: diag_sfn_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction ! [H L2 T-1 ~> m3 s-1 or kg s-1] real :: diag_sfn_unlim_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction before - ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] + ! applying limiters [Z L2 T-1 ~> m3 s-1] real :: diag_sfn_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction ! [H L2 T-1 ~> m3 s-1 or kg s-1] real :: diag_sfn_unlim_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction before - ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] + ! applying limiters [Z L2 T-1 ~> m3 s-1] logical :: present_slope_x, present_slope_y, calc_derivatives integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of ! state calculations at u-points. @@ -753,10 +775,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV I_slope_max2 = 1.0 / (CS%slope_max**2) G_scale = GV%g_Earth * GV%H_to_Z - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 - dz_neglect = GV%H_subroundoff*GV%H_to_Z + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 ; hn_2 = 0.5*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect**2 G_rho0 = GV%g_Earth / GV%Rho0 - N2_floor = CS%N2_floor*US%Z_to_L**2 + N2_floor = CS%N2_floor * US%Z_to_L**2 use_EOS = associated(tv%eqn_of_state) present_slope_x = PRESENT(slope_x) @@ -779,6 +801,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo, larger_h_denom=.true.) endif + ! Rescale the thicknesses, perhaps using the specific volume. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & "cg1 must be associated when using FGNV streamfunction.") @@ -824,20 +849,21 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV EOSdom_h1(:) = EOS_domain(G%HI, halo=1) !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & - !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & - !$OMP h_neglect2,int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & - !$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1,diag_sfn_x, & - !$OMP diag_sfn_unlim_x,N2_floor,EOSdom_u,EOSdom_h1,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 nk_linear,IsdB,tv,h,h_neglect,e,dz,dz_neglect,dz_neglect2, & + !$OMP h_neglect2,hn_2,I_slope_max2,int_slope_u,KH_u,uhtot, & + !$OMP h_frac,h_avail_rsum,uhD,h_avail,Work_u,CS,slope_x,cg1, & + !$OMP diag_sfn_x,diag_sfn_unlim_x,N2_floor,EOSdom_u,EOSdom_h1, & + !$OMP use_stanley,Tsgs2,present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & + !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u,G_scale, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,N2_unlim, & !$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, & + !$OMP dzg2A,dzg2B,dzaA,dzaB,dz_harm,Z_to_H, & + !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,dzN2_u, & + !$OMP Sfn_unlim_u,Rho_avg,drdi_u,drdkDe_u,c2_dz_u, & !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do j=js,je - do I=is-1,ie ; hN2_u(I,1) = 0. ; hN2_u(I,nz+1) = 0. ; enddo + do I=is-1,ie ; dzN2_u(I,1) = 0. ; dzN2_u(I,nz+1) = 0. ; enddo do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -907,9 +933,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect if (GV%Boussinesq) then dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z - else + elseif (GV%semi_Boussinesq) then dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect + else + dzaL = 0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect + dzaR = 0.5*(dz(i+1,j,k-1) + dz(i+1,j,k)) + dz_neglect endif ! Use the harmonic mean thicknesses to weight the horizontal gradients. ! These unnormalized weights have been rearranged to minimize divisions. @@ -924,10 +953,23 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + h_neglect haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect - ! hN2_u is used with the FGNV streamfunction formulation - hN2_u(I,K) = (0.5 * GV%H_to_Z * ( hg2A / haA + hg2B / haB )) * & - max(drdz*G_rho0, N2_floor) + if (GV%Boussinesq) then + N2_unlim = drdz*G_rho0 + else + N2_unlim = (GV%g_Earth*GV%RZ_to_H) * & + ((wtL * drdkL + wtR * drdkR) / (haL*wtL + haR*wtR)) + endif + + dzg2A = dz(i,j,k-1)*dz(i+1,j,k-1) + dz_neglect2 + dzg2B = dz(i,j,k)*dz(i+1,j,k) + dz_neglect2 + dzaA = 0.5*(dz(i,j,k-1) + dz(i+1,j,k-1)) + dz_neglect + dzaB = 0.5*(dz(i,j,k) + dz(i+1,j,k)) + dz_neglect + ! dzN2_u is used with the FGNV streamfunction formulation + dzN2_u(I,K) = (0.5 * ( dzg2A / dzaA + dzg2B / dzaB )) * max(N2_unlim, N2_floor) + if (find_work .and. CS%GM_src_alt) & + hN2_x_PE(I,j,k) = (0.5 * ( hg2A / haA + hg2B / haB )) * max(N2_unlim, N2_floor) endif + if (present_slope_x) then Slope = slope_x(I,j,k) slope2_Ratio_u(I,K) = Slope**2 * I_slope_max2 @@ -958,11 +1000,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV slope2_Ratio_u(I,K) = (1.0 - int_slope_u(I,j,K)) * slope2_Ratio_u(I,K) Slope_x_PE(I,j,k) = MIN(Slope,CS%slope_max) - hN2_x_PE(I,j,k) = hN2_u(I,K) if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. - Sfn_unlim_u(I,K) = -((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) + ! Estimate the streamfunction at each interface [H L2 T-1 ~> m3 s-1 or kg s-1]. + Sfn_unlim_u(I,K) = -(KH_u(I,j,K)*G%dy_Cu(I,j))*Slope ! Avoid moving dense water upslope from below the level of ! the bottom on the receiving side. @@ -992,10 +1033,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) - hN2_u(I,K) = GV%g_prime(K) + dzN2_u(I,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) - hN2_u(I,K) = N2_floor * dz_neglect + dzN2_u(I,K) = N2_floor * dz_neglect Sfn_unlim_u(I,K) = 0. endif ! if (k > nk_linear) if (CS%id_sfn_unlim_x>0) diag_sfn_unlim_x(I,j,K) = Sfn_unlim_u(I,K) @@ -1004,10 +1045,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%use_FGNV_streamfn) then do k=1,nz ; do I=is-1,ie ; if (G%OBCmaskCu(I,j)>0.) then - h_harm = max( h_neglect, & - 2. * h(i,j,k) * h(i+1,j,k) / ( ( h(i,j,k) + h(i+1,j,k) ) + h_neglect ) ) - c2_h_u(I,k) = CS%FGNV_scale * & - ( 0.5*( cg1(i,j) + cg1(i+1,j) ) )**2 / (GV%H_to_Z*h_harm) + dz_harm = max( dz_neglect, & + 2. * dz(i,j,k) * dz(i+1,j,k) / ( ( dz(i,j,k) + dz(i+1,j,k) ) + dz_neglect ) ) + c2_dz_u(I,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i+1,j) ) )**2 / dz_harm endif ; enddo ; enddo ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. @@ -1016,7 +1056,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=2,nz Sfn_unlim_u(I,K) = (1. + CS%FGNV_scale) * Sfn_unlim_u(I,K) enddo - call streamfn_solver(nz, c2_h_u(I,:), hN2_u(I,:), Sfn_unlim_u(I,:)) + call streamfn_solver(nz, c2_dz_u(I,:), dzN2_u(I,:), Sfn_unlim_u(I,:)) else do K=2,nz Sfn_unlim_u(I,K) = 0. @@ -1027,25 +1067,36 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=nz,2,-1 do I=is-1,ie + + if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i+1,j,k) + h(i+1,j,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k) + (h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1)) ) + ! Use an average density to convert the volume streamfunction estimate into a mass streamfunction. + Z_to_H = (GV%RZ_to_H*Rho_avg) + else + Z_to_H = GV%Z_to_H + endif + if (k > nk_linear) then if (use_EOS) then if (uhtot(I,j) <= 0.0) then ! The transport that must balance the transport below is positive. - Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i,j,k)) * GV%H_to_Z + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i,j,k)) else ! (uhtot(I,j) > 0.0) - Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i+1,j,k)) * GV%H_to_Z + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i+1,j,k)) endif - ! The actual streamfunction at each interface. - Sfn_est = (Sfn_unlim_u(I,K) + slope2_Ratio_u(I,K)*Sfn_safe) / (1.0 + slope2_Ratio_u(I,K)) - else ! With .not.use_EOS, the layers are constant density. - Sfn_est = Sfn_unlim_u(I,K) + ! Determine the actual streamfunction at each interface. + Sfn_est = (Z_to_H*Sfn_unlim_u(I,K) + slope2_Ratio_u(I,K)*Sfn_safe) / (1.0 + slope2_Ratio_u(I,K)) + else ! When use_EOS is false, the layers are constant density. + Sfn_est = Z_to_H*Sfn_unlim_u(I,K) endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. - Sfn_in_H = min(max(Sfn_est * GV%Z_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) + Sfn_in_H = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) ! The actual transport is limited by the mass available in the two ! neighboring grid cells. @@ -1076,6 +1127,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! else ! sfn_slope_x(I,j,K) = sfn_slope_x(I,j,K+1) * (1.0 - h_frac(i+1,j,k)) ! endif + endif uhtot(I,j) = uhtot(I,j) + uhD(I,j,k) @@ -1087,6 +1139,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! A second order centered estimate is used for the density transferred ! between water columns. + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth / Rho_avg + else + G_scale = GV%g_Earth * GV%H_to_Z + endif + Work_u(I,j) = Work_u(I,j) + G_scale * & ( uhtot(I,j) * drdkDe_u(I,K) - & (uhD(I,j,k) * drdi_u(I,k)) * 0.25 * & @@ -1099,18 +1157,19 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! Calculate the meridional fluxes and gradients. - !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & - !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S,dz, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,dz_neglect2, & !$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & - !$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1,diag_sfn_y, & - !$OMP diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,Tsgs2, & - !$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & + !$OMP I_slope_max2,vhD,h_avail,Work_v,CS,slope_y,cg1,hn_2,& + !$OMP diag_sfn_y,diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,& + !$OMP Tsgs2, present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v,S_h,S_hr, & - !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,drho_dT_dT_hr, scrap,pres_h,T_h,T_hr, & + !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA,G_scale, & + !$OMP drho_dT_dT_h,drho_dT_dT_hr,scrap,pres_h,T_h,T_hr, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz,pres_hr, & - !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & - !$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & + !$OMP dzg2A,dzg2B,dzaA,dzaB,dz_harm,Z_to_H, & + !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,dzN2_v,N2_unlim, & + !$OMP Sfn_unlim_v,Rho_avg,drdj_v,drdkDe_v,c2_dz_v, & !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do J=js-1,je do K=nz,2,-1 @@ -1186,11 +1245,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hg2R = h(i,j+1,k-1)*h(i,j+1,k) + h_neglect2 haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect + if (GV%Boussinesq) then dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z - else + elseif (GV%semi_Boussinesq) then dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect + else + dzaL = 0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect + dzaR = 0.5*(dz(i,j+1,k-1) + dz(i,j+1,k)) + dz_neglect endif ! Use the harmonic mean thicknesses to weight the horizontal gradients. ! These unnormalized weights have been rearranged to minimize divisions. @@ -1205,9 +1268,22 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haA = 0.5*(h(i,j,k-1) + h(i,j+1,k-1)) + h_neglect haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect - ! hN2_v is used with the FGNV streamfunction formulation - hN2_v(i,K) = (0.5 * GV%H_to_Z * ( hg2A / haA + hg2B / haB )) * & - max(drdz*G_rho0, N2_floor) + if (GV%Boussinesq) then + N2_unlim = drdz*G_rho0 + else + N2_unlim = (GV%g_Earth*GV%RZ_to_H) * & + ((wtL * drdkL + wtR * drdkR) / (haL*wtL + haR*wtR)) + endif + + dzg2A = dz(i,j,k-1)*dz(i,j+1,k-1) + dz_neglect2 + dzg2B = dz(i,j,k)*dz(i,j+1,k) + dz_neglect2 + dzaA = 0.5*(dz(i,j,k-1) + dz(i,j+1,k-1)) + dz_neglect + dzaB = 0.5*(dz(i,j,k) + dz(i,j+1,k)) + dz_neglect + + ! dzN2_v is used with the FGNV streamfunction formulation + dzN2_v(i,K) = (0.5*( dzg2A / dzaA + dzg2B / dzaB )) * max(N2_unlim, N2_floor) + if (find_work .and. CS%GM_src_alt) & + hN2_y_PE(i,J,k) = (0.5*( hg2A / haA + hg2B / haB )) * max(N2_unlim, N2_floor) endif if (present_slope_y) then Slope = slope_y(i,J,k) @@ -1239,10 +1315,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV slope2_Ratio_v(i,K) = (1.0 - int_slope_v(i,J,K)) * slope2_Ratio_v(i,K) Slope_y_PE(i,J,k) = MIN(Slope,CS%slope_max) - hN2_y_PE(i,J,k) = hN2_v(i,K) if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) ! Avoid moving dense water upslope from below the level of @@ -1273,10 +1347,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) - hN2_v(i,K) = GV%g_prime(K) + dzN2_v(i,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) - hN2_v(i,K) = N2_floor * dz_neglect + dzN2_v(i,K) = N2_floor * dz_neglect Sfn_unlim_v(i,K) = 0. endif ! if (k > nk_linear) if (CS%id_sfn_unlim_y>0) diag_sfn_unlim_y(i,J,K) = Sfn_unlim_v(i,K) @@ -1285,10 +1359,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%use_FGNV_streamfn) then do k=1,nz ; do i=is,ie ; if (G%OBCmaskCv(i,J)>0.) then - h_harm = max( h_neglect, & - 2. * h(i,j,k) * h(i,j+1,k) / ( ( h(i,j,k) + h(i,j+1,k) ) + h_neglect ) ) - c2_h_v(i,k) = CS%FGNV_scale * & - ( 0.5*( cg1(i,j) + cg1(i,j+1) ) )**2 / (GV%H_to_Z*h_harm) + dz_harm = max( dz_neglect, & + 2. * dz(i,j,k) * dz(i,j+1,k) / ( ( dz(i,j,k) + dz(i,j+1,k) ) + dz_neglect ) ) + c2_dz_v(i,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i,j+1) ) )**2 / dz_harm endif ; enddo ; enddo ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. @@ -1297,7 +1370,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=2,nz Sfn_unlim_v(i,K) = (1. + CS%FGNV_scale) * Sfn_unlim_v(i,K) enddo - call streamfn_solver(nz, c2_h_v(i,:), hN2_v(i,:), Sfn_unlim_v(i,:)) + call streamfn_solver(nz, c2_dz_v(i,:), dzN2_v(i,:), Sfn_unlim_v(i,:)) else do K=2,nz Sfn_unlim_v(i,K) = 0. @@ -1308,25 +1381,35 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=nz,2,-1 do i=is,ie + if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i,j+1,k) + h(i,j+1,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k) + (h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1)) ) + ! Use an average density to convert the volume streamfunction estimate into a mass streamfunction. + Z_to_H = (GV%RZ_to_H*Rho_avg) + else + Z_to_H = GV%Z_to_H + endif + if (k > nk_linear) then if (use_EOS) then if (vhtot(i,J) <= 0.0) then ! The transport that must balance the transport below is positive. - Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j,k)) * GV%H_to_Z + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j,k)) else ! (vhtot(I,j) > 0.0) - Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j+1,k)) * GV%H_to_Z + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j+1,k)) endif - ! The actual streamfunction at each interface. - Sfn_est = (Sfn_unlim_v(i,K) + slope2_Ratio_v(i,K)*Sfn_safe) / (1.0 + slope2_Ratio_v(i,K)) - else ! With .not.use_EOS, the layers are constant density. - Sfn_est = Sfn_unlim_v(i,K) + ! Find the actual streamfunction at each interface. + Sfn_est = (Z_to_H*Sfn_unlim_v(i,K) + slope2_Ratio_v(i,K)*Sfn_safe) / (1.0 + slope2_Ratio_v(i,K)) + else ! When use_EOS is false, the layers are constant density. + Sfn_est = Z_to_H*Sfn_unlim_v(i,K) endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. - Sfn_in_H = min(max(Sfn_est * GV%Z_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) + Sfn_in_H = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) ! The actual transport is limited by the mass available in the two ! neighboring grid cells. @@ -1367,6 +1450,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! A second order centered estimate is used for the density transferred ! between water columns. + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth / Rho_avg + else + G_scale = GV%g_Earth * GV%H_to_Z + endif + Work_v(i,J) = Work_v(i,J) + G_scale * & ( vhtot(i,J) * drdkDe_v(i,K) - & (vhD(i,J,k) * drdj_v(i,k)) * 0.25 * & @@ -1383,7 +1472,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do J=js-1,je ; do i=is,ie ; vhD(i,J,1) = -vhtot(i,J) ; enddo ; enddo else EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) - !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB) + !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB,G_scale) do j=js,je if (use_EOS) then do I=is-1,ie @@ -1397,9 +1486,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do I=is-1,ie uhD(I,j,1) = -uhtot(I,j) + G_scale = GV%g_Earth * GV%H_to_Z if (use_EOS) then drdiB = drho_dT_u(I) * (T(i+1,j,1)-T(i,j,1)) + & drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1)) + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth * & + ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1) + (h(i+1,j,1)+hn_2) * tv%SpV_avg(i+1,j,1)) / & + ( (h(i,j,1) + h(i+1,j,1)) + 2.0*hn_2 ) ) + endif endif if (CS%use_GM_work_bug) then Work_u(I,j) = Work_u(I,j) + G_scale * & @@ -1414,7 +1509,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo EOSdom_v(:) = EOS_domain(G%HI) - !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB) + !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB,G_scale) do J=js-1,je if (use_EOS) then do i=is,ie @@ -1428,9 +1523,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do i=is,ie vhD(i,J,1) = -vhtot(i,J) + G_scale = GV%g_Earth * GV%H_to_Z if (use_EOS) then drdjB = drho_dT_v(i) * (T(i,j+1,1)-T(i,j,1)) + & drho_dS_v(i) * (S(i,j+1,1)-S(i,j,1)) + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth * & + ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1) + (h(i,j+1,1)+hn_2) * tv%SpV_avg(i,j+1,1)) / & + ( (h(i,j,1) + h(i,j+1,1)) + 2.0*hn_2 ) ) + endif endif Work_v(i,J) = Work_v(i,J) - G_scale * & ( (vhD(i,J,1) * drdjB) * 0.25 * & @@ -1451,11 +1552,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (find_work .and. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then do j=js,je ; do i=is,ie ; do k=nz,1,-1 - PE_release_h = -0.25*(KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & + PE_release_h = -0.25 * (GV%H_to_RZ*US%L_to_Z**2) * & + (KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k) + & Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + & Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)) - MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + US%L_to_Z**2 * GV%Rho0 * PE_release_h + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h enddo ; enddo ; enddo endif ; endif @@ -1471,16 +1573,18 @@ end subroutine thickness_diffuse_full !> Tridiagonal solver for streamfunction at interfaces subroutine streamfn_solver(nk, c2_h, hN2, sfn) integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers [L2 Z-1 T-2 ~> m s-2] - real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces [L2 Z-1 T-2 ~> m s-2] - real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [Z L2 T-1 ~> m3 s-1] or arbitrary units + real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers, rescaled to + !! [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces times rescaling factors + !! [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] or arbitrary units !! On entry, equals diffusivity times slope. !! On exit, equals the streamfunction. ! Local variables real :: c1(nk) ! The dependence of the final streamfunction on the values below [nondim] real :: d1 ! The complement of c1(k) (i.e., 1 - c1(k)) [nondim] - real :: b_denom ! A term in the denominator of beta [L2 Z-1 T-2 ~> m s-2] - real :: beta ! The normalization for the pivot [Z T2 L-2 ~> s2 m-1] + real :: b_denom ! A term in the denominator of beta [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real :: beta ! The normalization for the pivot [Z2 T2 H-1 L-2 ~> s2 m-1 or m2 s2 kg-1] integer :: k sfn(1) = 0. From 147ddf1d5707e79f3268c430d396f33e7d9956c3 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 25 Jul 2023 08:17:15 -0800 Subject: [PATCH 015/146] Brine plume (#401) * Salt data structures * First steps at brine plume: pass info from SIS2 * The brine plume parameterization, - including now passing the dimensional scaling tests. * Fix problem when running Tidal_bay case with gnu. * Avoiding visc_rem issues inside land mask. Tweaking the brine plume code. * Using the proper MLD in the brine plumes - it now works better on restart * Always including MLD in call to applyBoundary... - I could move it up and make it not optional. * Adding some OpenMP directives to brine plumes --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 13 ++- docs/zotero.bib | 9 ++ src/core/MOM_continuity_PPM.F90 | 8 +- src/core/MOM_forcing_type.F90 | 16 ++-- .../vertical/MOM_diabatic_aux.F90 | 82 +++++++++++++++++-- .../vertical/MOM_diabatic_driver.F90 | 8 +- .../vertical/MOM_set_viscosity.F90 | 34 ++++---- 7 files changed, 132 insertions(+), 38 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index 251f37290d..a8398c3cc8 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -62,7 +62,7 @@ module MOM_surface_forcing_gfdl !! from MOM_domains) to indicate the staggering of !! the winds that are being provided in calls to !! update_ocean_model. - logical :: use_temperature !< If true, temp and saln used as state variables + logical :: use_temperature !< If true, temp and saln used as state variables. real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress [nondim]. real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] @@ -175,6 +175,7 @@ module MOM_surface_forcing_gfdl real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W m-2] real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux [kg m-2 s-1] real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux [kg m-2 s-1] + real, pointer, dimension(:,:) :: excess_salt =>NULL() !< salt left behind by brine rejection [kg m-2 s-1] real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation [W m-2] real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation [W m-2] real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation [W m-2] @@ -304,6 +305,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + if (associated(IOB%excess_salt)) call safe_alloc_ptr(fluxes%salt_left_behind,isd,ied,jsd,jed) + do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) @@ -576,6 +579,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call check_mask_val_consistency(IOB%salt_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 'salt_flux', G) enddo ; enddo endif + if (associated(IOB%excess_salt)) then + do j=js,je ; do i=is,ie + fluxes%salt_left_behind(i,j) = G%mask2dT(i,j)*(kg_m2_s_conversion*IOB%excess_salt(i-i0,j-j0)) + enddo ; enddo + endif !#CTRL# if (associated(CS%ctrl_forcing_CSp)) then !#CTRL# do j=js,je ; do i=is,ie @@ -1729,6 +1737,9 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) if (associated(iobt%mass_berg)) then chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks endif + if (associated(iobt%excess_salt)) then + chks = field_chksum( iobt%excess_salt ) ; if (root) write(outunit,100) 'iobt%excess_salt ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') diff --git a/docs/zotero.bib b/docs/zotero.bib index c0c7ee3bd9..5acaee968a 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2738,3 +2738,12 @@ @article{kraus1967 journal = {Tellus} } +@article{Nguyen2009, + doi = {10.1029/2008JC005121}, + year = {2009}, + journal = {JGR Oceans}, + volume = {114}, + author = {A. T. Nguyen and D. Menemenlis and R. Kwok}, + title = {Improved modeling of the Arctic halocline with a subgrid-scale brine rejection parameterization}, + pages = {C11014} +} diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 090d1ee0fb..73c6503242 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -378,9 +378,9 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j)) else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif - if (du_max_CFL(I) * visc_rem(I,k) > dx_W*CFL_dt - u(I,j,k)) & + if (du_max_CFL(I) * visc_rem(I,k) > dx_W*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) & du_max_CFL(I) = (dx_W*CFL_dt - u(I,j,k)) / visc_rem(I,k) - if (du_min_CFL(I) * visc_rem(I,k) < -dx_E*CFL_dt - u(I,j,k)) & + if (du_min_CFL(I) * visc_rem(I,k) < -dx_E*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) & du_min_CFL(I) = -(dx_E*CFL_dt + u(I,j,k)) / visc_rem(I,k) enddo ; enddo endif @@ -1201,9 +1201,9 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j)) dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1)) else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif - if (dv_max_CFL(i) * visc_rem(i,k) > dy_S*CFL_dt - v(i,J,k)) & + if (dv_max_CFL(i) * visc_rem(i,k) > dy_S*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) & dv_max_CFL(i) = (dy_S*CFL_dt - v(i,J,k)) / visc_rem(i,k) - if (dv_min_CFL(i) * visc_rem(i,k) < -dy_N*CFL_dt - v(i,J,k)) & + if (dv_min_CFL(i) * visc_rem(i,k) < -dy_N*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) & dv_min_CFL(i) = -(dy_N*CFL_dt + v(i,J,k)) / visc_rem(i,k) enddo ; enddo endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 4897771100..9623256b88 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -135,8 +135,10 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & salt_flux => NULL(), & !< net salt flux into the ocean [R Z T-1 ~> kgSalt m-2 s-1] salt_flux_in => NULL(), & !< salt flux provided to the ocean from coupler [R Z T-1 ~> kgSalt m-2 s-1] - salt_flux_added => NULL() !< additional salt flux from restoring or flux adjustment before adjustment + salt_flux_added => NULL(), & !< additional salt flux from restoring or flux adjustment before adjustment !! to net zero [R Z T-1 ~> kgSalt m-2 s-1] + salt_left_behind => NULL() !< salt left in ocean at the surface from brine rejection + !! [R Z T-1 ~> kgSalt m-2 s-1] ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) real, pointer, dimension(:,:) :: p_surf_full => NULL() @@ -746,15 +748,15 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & endif ! Salt fluxes - Net_salt(i) = 0.0 - if (do_NSR) Net_salt_rate(i) = 0.0 + net_salt(i) = 0.0 + if (do_NSR) net_salt_rate(i) = 0.0 ! Convert salt_flux from kg (salt)/(m^2 * s) to ! Boussinesq: (ppt * m) ! non-Bouss: (g/m^2) if (associated(fluxes%salt_flux)) then - Net_salt(i) = (scale * dt * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H + net_salt(i) = (scale * dt * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H !Repeat above code for 'rate' term - if (do_NSR) Net_salt_rate(i) = (scale * 1. * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H + if (do_NSR) net_salt_rate(i) = (scale * 1. * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H endif ! Diagnostics follow... @@ -1947,6 +1949,10 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, diag%axesT1,Time,'Salt flux into ocean at surface due to restoring or flux adjustment', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + handles%id_saltFluxAdded = register_diag_field('ocean_model', 'salt_left_behind', & + diag%axesT1,Time,'Salt left in ocean at surface due to ice formation', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + handles%id_saltFluxGlobalAdj = register_scalar_field('ocean_model', & 'salt_flux_global_restoring_adjustment', Time, diag, & 'Adjustment needed to balance net global salt flux into ocean at surface', & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index ba265af5e2..3742e93229 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -67,7 +67,10 @@ module MOM_diabatic_aux !! e-folding depth of incoming shortwave radiation. type(external_field) :: sbc_chl !< A handle used in time interpolation of !! chlorophyll read from a file. - logical :: chl_from_file !< If true, chl_a is read from a file. + logical :: chl_from_file !< If true, chl_a is read from a file. + logical :: do_brine_plume !< If true, insert salt flux below the surface according to + !! a parameterization by \cite Nguyen2009. + integer :: brine_plume_n !< The exponent in the brine plume parameterization. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output @@ -1034,7 +1037,7 @@ end subroutine diagnoseMLDbyEnergy subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, tv, & aggregate_FW_forcing, evap_CFL_limit, & minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, & - SkinBuoyFlux ) + SkinBuoyFlux, MLD) type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1064,6 +1067,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 T-3 ~> m2 s-3]. + real, pointer, dimension(:,:), optional :: MLD!< Mixed layer depth for brine plumes [Z ~> m] ! Local variables integer, parameter :: maxGroundings = 5 @@ -1102,7 +1106,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t netheat_rate, & ! netheat but for dt=1 [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - netMassInOut_rate! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] + netMassInOut_rate, & ! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] + mixing_depth ! Mixed layer depth [Z -> m] real, dimension(SZI_(G), SZK_(GV)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] T2d, & ! A 2-d copy of the layer temperatures [C ~> degC] @@ -1132,6 +1137,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! and rejected brine are initially applied in vanishingly thin layers at the ! top of the layer before being mixed throughout the layer. logical :: calculate_buoyancy ! If true, calculate the surface buoyancy flux. + real, dimension(SZI_(G)) :: dK ! Depth [Z ~> m]. + real, dimension(SZI_(G)) :: A_brine ! Constant [Z-(n+1) ~> m-(n+1)]. + real :: fraction_left_brine ! Sum for keeping track of the fraction of brine so far (in depth) + real :: plume_fraction ! Sum for keeping track of the fraction of brine so far (in depth) + real :: plume_flux ! Brine flux to move downwards [S H ~> ppt m or ppt kg m-2] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, nb character(len=45) :: mesg @@ -1139,6 +1149,7 @@ 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 = GV%ke Idt = 1.0 / dt + plume_flux = 0.0 calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) @@ -1158,6 +1169,17 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 endif + if (CS%do_brine_plume .and. .not. associated(MLD)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires a mixed-layer depth,\n"//& + "currently coming from the energetic PBL scheme.") + endif + if (CS%do_brine_plume .and. .not. associated(fluxes%salt_left_behind)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires DO_BRINE_PLUME\n"//& + "to be turned on in SIS2 as well as MOM6.") + endif + ! H_limit_fluxes is used by extractFluxes1d to scale down fluxes if the total ! depth of the ocean is vanishing. It does not (yet) handle a value of zero. ! To accommodate vanishing upper layers, we need to allow for an instantaneous @@ -1173,9 +1195,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & !$OMP minimum_forcing_depth,evap_CFL_limit,dt,EOSdom, & - !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho, & + !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho,& !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2, & - !$OMP EnthalpyConst) & + !$OMP EnthalpyConst,MLD) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & !$OMP IforcingDepthScale, & @@ -1183,7 +1205,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP netMassIn,pres,d_pres,p_lay,dSV_dT_2d, & !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & !$OMP drhodt,drhods,pen_sw_bnd_rate, & - !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst) & + !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & + !$OMP mixing_depth,A_brine,fraction_left_brine, & + !$OMP plume_flux,plume_fraction,dK) & !$OMP firstprivate(SurfPressure) do j=js,je ! Work in vertical slices for efficiency @@ -1300,6 +1324,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! ocean (and corresponding outward heat content), and ignoring penetrative SW. ! B/ update mass, salt, temp from mass leaving ocean. ! C/ update temp due to penetrative SW + if (CS%do_brine_plume) then + do i=is,ie + mixing_depth(i) = max(MLD(i,j) - minimum_forcing_depth * GV%H_to_Z, minimum_forcing_depth * GV%H_to_Z) + mixing_depth(i) = min(mixing_depth(i), max(sum(h(i,j,:)), GV%angstrom_h) * GV%H_to_Z) + A_brine(i) = (CS%brine_plume_n + 1) / (mixing_depth(i) ** (CS%brine_plume_n + 1)) + enddo + endif + do i=is,ie if (G%mask2dT(i,j) > 0.) then @@ -1372,8 +1404,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t enddo ! k=1,1 ! B/ Update mass, salt, temp from mass leaving ocean and other fluxes of heat and salt. + fraction_left_brine = 1.0 do k=1,nz - ! Place forcing into this layer if this layer has nontrivial thickness. ! For layers thin relative to 1/IforcingDepthScale, then distribute ! forcing into deeper layers. @@ -1388,6 +1420,33 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t fractionOfForcing = -evap_CFL_limit*h2d(i,k)/netMassOut(i) endif + if (CS%do_brine_plume .and. associated(fluxes%salt_left_behind)) then + if (fluxes%salt_left_behind(i,j) > 0 .and. fraction_left_brine > 0.0) then + ! Place forcing into this layer by depth for brine plume parameterization. + if (k == 1) then + dK(i) = 0.5 * h(i,j,k) * GV%H_to_Z ! Depth of center of layer K + plume_flux = - (1000.0*US%ppt_to_S * fluxes%salt_left_behind(i,j)) * GV%RZ_to_H + plume_fraction = 1.0 + else + dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K + plume_flux = 0.0 + endif + if (dK(i) <= mixing_depth(i) .and. fraction_left_brine > 0.0) then + plume_fraction = min(fraction_left_brine, A_brine(i) * dK(i) ** CS%brine_plume_n & + * h(i,j,k) * GV%H_to_Z) + else + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) + ! plume_fraction = fraction_left_brine, unless h2d is less than IforcingDepthScale. + plume_fraction = min(fraction_left_brine, h2d(i,k)*IforcingDepthScale) + endif + fraction_left_brine = fraction_left_brine - plume_fraction + plume_flux = plume_flux + plume_fraction * (1000.0*US%ppt_to_S * fluxes%salt_left_behind(i,j)) & + * GV%RZ_to_H + else + plume_flux = 0.0 + endif + endif + ! Change in state due to forcing dThickness = max( fractionOfForcing*netMassOut(i), -h2d(i,k) ) @@ -1432,7 +1491,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t endif Ithickness = 1.0/h2d(i,k) ! Inverse of new thickness T2d(i,k) = (hOld*T2d(i,k) + dTemp)*Ithickness - tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt)*Ithickness + tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt + plume_flux)*Ithickness elseif (h2d(i,k) < 0.0) then ! h2d==0 is a special limit that needs no extra handling call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (h<0)') write(0,*) 'applyBoundaryFluxesInOut(): lon,lat=',G%geoLonT(i,j),G%geoLatT(i,j) @@ -1702,6 +1761,13 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori CS%use_calving_heat_content = .false. endif + call get_param(param_file, mdl, "DO_BRINE_PLUME", CS%do_brine_plume, & + "If true, use a brine plume parameterization from "//& + "Nguyen et al., 2009.", default=.false.) + call get_param(param_file, mdl, "BRINE_PLUME_EXPONENT", CS%brine_plume_n, & + "If using the brine plume parameterization, set the integer exponent.", & + default=5, do_not_log=.not.CS%do_brine_plume) + if (useALEalgorithm) then CS%id_createdH = register_diag_field('ocean_model',"created_H",diag%axesT1, & Time, "The volume flux added to stop the ocean from drying out and becoming negative in depth", & diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 0c28c063ea..466ebbabca 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -815,7 +815,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) if (CS%debug) then call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) @@ -875,7 +875,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) endif ! endif for CS%use_energetic_PBL @@ -1360,7 +1360,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) if (CS%debug) then call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) @@ -1414,7 +1414,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) endif ! endif for CS%use_energetic_PBL diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 47d4dffef6..481aa5e9fc 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1027,22 +1027,24 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif endif - if (CS%body_force_drag .and. (h_bbl_drag(i) > 0.0)) then - ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. - h_sum = 0.0 - I_hwtot = 1.0 / h_bbl_drag(i) - do k=nz,1,-1 - h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot - if (m==1) then - visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr - else - visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr - endif - h_sum = h_sum + h_at_vel(i,k) - if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. - enddo - ! Do not enhance the near-bottom viscosity in this case. - Kv_bbl = CS%Kv_BBL_min + if (CS%body_force_drag) then + if (h_bbl_drag(i) > 0.0) then + ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. + h_sum = 0.0 + I_hwtot = 1.0 / h_bbl_drag(i) + do k=nz,1,-1 + h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot + if (m==1) then + visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr + else + visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr + endif + h_sum = h_sum + h_at_vel(i,k) + if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. + enddo + ! Do not enhance the near-bottom viscosity in this case. + Kv_bbl = CS%Kv_BBL_min + endif endif kv_bbl = max(CS%Kv_BBL_min, kv_bbl) From d5ba107af21757390fb82d123ae1bf9c236ec0e4 Mon Sep 17 00:00:00 2001 From: Spencer Jones <41342785+cspencerjones@users.noreply.github.com> Date: Tue, 25 Jul 2023 13:14:17 -0500 Subject: [PATCH 016/146] +add h to drifters interface (#408) This commit brings the drifters interface up-to-date with the current version of the drifters package, which requires h (layer thickness) to calculate the vertical movement of particles. The interfaces in the code and in config_src/external are updated to pass this information to the drifters package. --- .../external/drifters/MOM_particles.F90 | 44 +++++++++++++------ src/core/MOM.F90 | 17 +++++-- 2 files changed, 44 insertions(+), 17 deletions(-) diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index aad918e5a4..fa3840c6c2 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -11,19 +11,20 @@ module MOM_particles_mod implicit none ; private public particles, particles_run, particles_init, particles_save_restart, particles_end +public particles_to_k_space, particles_to_z_space contains !> Initializes particles container "parts" -subroutine particles_init(parts, Grid, Time, dt, u, v) +subroutine particles_init(parts, Grid, Time, dt, u, v, h) ! Arguments type(particles), pointer, intent(out) :: parts !< Container for all types and memory type(ocean_grid_type), target, intent(in) :: Grid !< Grid type from parent model type(time_type), intent(in) :: Time !< Time type from parent model - real, intent(in) :: dt !< particle timestep [s] - real, dimension(:,:,:), intent(in) :: u !< Zonal velocity field [m s-1] - real, dimension(:,:,:), intent(in) :: v !< Meridional velocity field [m s-1] - + real, intent(in) :: dt !< particle timestep in seconds [T ~> s] + real, dimension(:,:,:),intent(in) :: u !< Zonal velocity field [L T-1 ~> m s-1] + real, dimension(:,:,:),intent(in) :: v !< Meridional velocity field [L T-1 ~> m s-1] + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] end subroutine particles_init !> The main driver the steps updates particles @@ -31,8 +32,8 @@ subroutine particles_run(parts, time, uo, vo, ho, tv, stagger) ! Arguments type(particles), pointer :: parts !< Container for all types and memory type(time_type), intent(in) :: time !< Model time - real, dimension(:,:,:), intent(in) :: uo !< Ocean zonal velocity [m s-1] - real, dimension(:,:,:), intent(in) :: vo !< Ocean meridional velocity [m s-1] + real, dimension(:,:,:), intent(in) :: uo !< Ocean zonal velocity [L T-1 ~>m s-1] + real, dimension(:,:,:), intent(in) :: vo !< Ocean meridional velocity [L T-1~> m s-1] real, dimension(:,:,:), intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields integer, optional, intent(in) :: stagger !< Flag for whether velocities are staggered @@ -41,21 +42,38 @@ end subroutine particles_run !>Save particle locations (and sometimes other vars) to restart file -subroutine particles_save_restart(parts, temp, salt) +subroutine particles_save_restart(parts, h, temp, salt) ! Arguments type(particles), pointer :: parts !< Container for all types and memory - real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature - real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature [C ~> degC] + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity [S ~> ppt] end subroutine particles_save_restart !> Deallocate all memory and disassociated pointer -subroutine particles_end(parts, temp, salt) +subroutine particles_end(parts, h, temp, salt) ! Arguments type(particles), pointer :: parts !< Container for all types and memory - real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature - real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature [C ~> degC] + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity [S ~> ppt] end subroutine particles_end +subroutine particles_to_k_space(parts, h) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of layers [H ~> m or kg m-2] + +end subroutine particles_to_k_space + + +subroutine particles_to_z_space(parts, h) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of layers [H ~> m or kg m-2] + +end subroutine particles_to_z_space + end module MOM_particles_mod diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index df3a308e85..d2df26524d 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -162,7 +162,7 @@ module MOM use MOM_offline_main, only : offline_advection_layer, offline_transport_end use MOM_ice_shelf, only : ice_shelf_CS, ice_shelf_query, initialize_ice_shelf use MOM_particles_mod, only : particles, particles_init, particles_run, particles_save_restart, particles_end - +use MOM_particles_mod, only : particles_to_k_space, particles_to_z_space implicit none ; private #include @@ -1541,6 +1541,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) + if (CS%use_particles) then + call particles_to_z_space(CS%particles, h) + endif + if (CS%debug) then call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US, omit_corners=.true.) call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) @@ -1588,6 +1592,11 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_end(id_clock_ALE) endif ! endif for the block "if ( CS%use_ALE_algorithm )" + + if (CS%use_particles) then + call particles_to_k_space(CS%particles, h) + endif + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) call create_group_pass(pass_uv_T_S_h, u, v, G%Domain, halo=dynamics_stencil) if (associated(tv%T)) & @@ -3232,7 +3241,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) G => CS%G ; GV => CS%GV ; US => CS%US if (CS%use_particles) then - call particles_init(CS%particles, G, CS%Time, CS%dt_therm, CS%u, CS%v) + call particles_init(CS%particles, G, CS%Time, CS%dt_therm, CS%u, CS%v, CS%h) endif ! Write initial conditions @@ -3935,7 +3944,7 @@ subroutine save_MOM6_internal_state(CS, dirs, time, stamp_time) ! Could call save_restart(CS%restart_CSp) here - if (CS%use_particles) call particles_save_restart(CS%particles) + if (CS%use_particles) call particles_save_restart(CS%particles, CS%h) end subroutine save_MOM6_internal_state @@ -3978,7 +3987,7 @@ subroutine MOM_end(CS) endif if (CS%use_particles) then - call particles_end(CS%particles) + call particles_end(CS%particles, CS%h) deallocate(CS%particles) endif From 249a0788d8a041cd7a4cef497aa1c5b2cf75931d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 11 Jul 2023 17:40:32 -0400 Subject: [PATCH 017/146] +*Revise units of arguments to vert_fill_TS Pass dt_kappa_smooth to calc_isoneutral_slopes and vert_fill_TS in units of [H Z ~> m2 or kg m-1] instead of [Z2 ~> m2] for consistency with the units of other diffusivities in the code and to reduce the depenency on the Boussinesq reference density in non-Boussinesq configurations. In addition to the changes to the units of these two arguments, there is a new unit_scale_type argument to vert_fill_TS and MOM_calc_varT and a new verticalGrid_type argument to MOM_stoch_eos_init. The units of 4 vertical diffusivities in the control structures in 4 different modules are also changed accordingly. All answers are bitwise identical in Boussinesq mode, but they can change for some non-Boussinesq configurations. There are new mandatory arguments to three publicly visible routines. --- src/core/MOM.F90 | 4 +-- src/core/MOM_isopycnal_slopes.F90 | 34 +++++++++++-------- src/core/MOM_stoch_eos.F90 | 12 ++++--- src/parameterizations/lateral/MOM_MEKE.F90 | 3 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 4 +-- .../lateral/MOM_thickness_diffuse.F90 | 10 +++--- .../vertical/MOM_internal_tide_input.F90 | 6 ++-- .../vertical/MOM_set_diffusivity.F90 | 12 +++---- 8 files changed, 46 insertions(+), 39 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d2df26524d..d7e2d74735 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1090,7 +1090,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call cpu_clock_end(id_clock_stoch) call cpu_clock_begin(id_clock_varT) if (CS%use_stochastic_EOS) then - call MOM_calc_varT(G, GV, h, CS%tv, CS%stoch_eos_CS, dt) + call MOM_calc_varT(G, GV, US, h, CS%tv, CS%stoch_eos_CS, dt) if (associated(CS%tv%varT)) call pass_var(CS%tv%varT, G%Domain, clock=id_clock_pass, halo=1) endif call cpu_clock_end(id_clock_varT) @@ -3022,7 +3022,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & new_sim = is_new_run(restart_CSp) if (use_temperature) then - CS%use_stochastic_EOS = MOM_stoch_eos_init(Time, G, US, param_file, diag, CS%stoch_eos_CS, restart_CSp) + CS%use_stochastic_EOS = MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS%stoch_eos_CS, restart_CSp) else CS%use_stochastic_EOS = .false. endif diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 07dd19b0a6..73ae8a9816 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -36,8 +36,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface heights [Z ~> m] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables - real, intent(in) :: dt_kappa_smooth !< A smoothing vertical diffusivity - !! times a smoothing timescale [Z2 ~> m2]. + real, intent(in) :: dt_kappa_smooth !< A smoothing vertical + !! diffusivity times a smoothing + !! timescale [H Z ~> m2 or kg m-1] logical, intent(in) :: use_stanley !< turn on stanley param in slope real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-dir [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-dir [Z L-1 ~> nondim] @@ -142,7 +143,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 - dz_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff local_open_u_BC = .false. local_open_v_BC = .false. @@ -195,9 +196,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan if (use_EOS) then if (present(halo)) then - call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, halo+1) + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, US, halo+1) else - call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, 1) + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, US, 1) endif endif @@ -341,9 +342,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) endif slope_x(I,j,K) = slope - if (present(dzSxN)) dzSxN(I,j,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N - * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 + if (present(dzSxN)) & + dzSxN(I,j,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 enddo ! I enddo ; enddo ! end of j-loop @@ -477,9 +479,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) endif slope_y(i,J,K) = slope - if (present(dzSyN)) dzSyN(i,J,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N - * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 + if (present(dzSyN)) & + dzSyN(i,J,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 enddo ! i enddo ; enddo ! end of j-loop @@ -488,14 +491,15 @@ end subroutine calc_isoneutral_slopes !> Returns tracer arrays (nominally T and S) with massless layers filled with !! sensible values, by diffusing vertically with a small but constant diffusivity. -subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, larger_h_denom) +subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, US, halo_here, larger_h_denom) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_in !< Input temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_in !< Input salinity [S ~> ppt] real, intent(in) :: kappa_dt !< A vertical diffusivity to use for smoothing - !! times a smoothing timescale [Z2 ~> m2]. + !! times a smoothing timescale [H Z ~> m2 or kg m-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T_f !< Filled temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S_f !< Filled salinity [S ~> ppt] integer, optional, intent(in) :: halo_here !< Number of halo points to work on, @@ -525,10 +529,10 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, lar is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke h_neglect = GV%H_subroundoff - kap_dt_x2 = (2.0*kappa_dt)*GV%Z_to_H**2 + kap_dt_x2 = (2.0*kappa_dt) * (US%Z_to_m*GV%m_to_H) ! Usually the latter term is GV%Z_to_H. h0 = h_neglect if (present(larger_h_denom)) then - if (larger_h_denom) h0 = 1.0e-16*sqrt(kappa_dt)*GV%Z_to_H + if (larger_h_denom) h0 = 1.0e-16*sqrt(0.5*kap_dt_x2) endif if (kap_dt_x2 <= 0.0) then diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90 index deb878e99c..2bd742be6d 100644 --- a/src/core/MOM_stoch_eos.F90 +++ b/src/core/MOM_stoch_eos.F90 @@ -40,7 +40,7 @@ module MOM_stoch_eos real :: stanley_coeff !< Coefficient correlating the temperature gradient !! and SGS T variance [nondim]; if <0, turn off scheme in all codes real :: stanley_a !< a in exp(aX) in stochastic coefficient [nondim] - real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [Z2 T-1 ~> m2 s-1] + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !>@{ Diagnostic IDs integer :: id_stoch_eos = -1, id_stoch_phi = -1, id_tvar_sgs = -1 @@ -51,9 +51,10 @@ module MOM_stoch_eos contains !> Initializes MOM_stoch_eos module, returning a logical indicating whether this module will be used. -logical function MOM_stoch_eos_init(Time, G, US, param_file, diag, CS, restart_CS) +logical function MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS, restart_CS) type(time_type), intent(in) :: Time !< Time for stochastic process type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse type(diag_ctrl), target, intent(inout) :: diag !< Structure used to control diagnostics @@ -80,7 +81,7 @@ logical function MOM_stoch_eos_init(Time, G, US, param_file, diag, CS, restart_C call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s, & + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T, & do_not_log=(CS%stanley_coeff<0.0)) ! Don't run anything if STANLEY_COEFF < 0 @@ -193,9 +194,10 @@ subroutine post_stoch_EOS_diags(CS, tv, diag) end subroutine post_stoch_EOS_diags !> Computes a parameterization of the SGS temperature variance -subroutine MOM_calc_varT(G, GV, h, tv, CS, dt) +subroutine MOM_calc_varT(G, GV, US, h, tv, CS, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure @@ -219,7 +221,7 @@ subroutine MOM_calc_varT(G, GV, h, tv, CS, dt) ! extreme gradients along layers which are vanished against topography. It is ! still a poor approximation in the interior when coordinates are strongly tilted. if (.not. associated(tv%varT)) allocate(tv%varT(G%isd:G%ied, G%jsd:G%jed, GV%ke), source=0.0) - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo_here=1, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, US, halo_here=1, larger_h_denom=.true.) do k=1,G%ke do j=G%jsc,G%jec diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 02338fab96..0ef261a956 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1578,7 +1578,8 @@ subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, f h_v(i,J,k) = 0.5*(h(i,j,k)*G%mask2dT(i,j) + h(i,j+1,k)*G%mask2dT(i,j+1)) + GV%Angstrom_H enddo; enddo; enddo; call find_eta(h, tv, G, GV, US, e, halo_size=2) - call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*1.e-7, .false., slope_x, slope_y) + ! Note the hard-coded dimenisional constant in the following line. + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*1.e-7*GV%m2_s_to_HZ_T, .false., slope_x, slope_y) call pass_vector(slope_x, slope_y, G%Domain) do j=js-1,je+1; do i=is-1,ie+1 slope_x_vert_avg(I,j) = vertical_average_interface(slope_x(i,j,:), h_u(i,j,:), GV%H_subroundoff) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 8f0aa02b12..e74e48055a 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -135,7 +135,7 @@ module MOM_lateral_mixing_coeffs !! F = 1 / (1 + (Res_coef_visc*Ld/dx)^Res_fn_power) real :: depth_scaled_khth_h0 !< The depth above which KHTH is linearly scaled away [Z ~> m] real :: depth_scaled_khth_exp !< The exponent used in the depth dependent scaling function for KHTH [nondim] - real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [Z2 T-1 ~> m2 s-1] + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] integer :: Res_fn_power_khth !< The power of dx/Ld in the KhTh resolution function. Any !! positive integer power may be used, but even powers !! and especially 2 are coded to be more efficient. @@ -1265,7 +1265,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) endif if (CS%calculate_Eady_growth_rate) then diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 8617795e16..f24f790d06 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -44,9 +44,9 @@ module MOM_thickness_diffuse real :: Kh_eta_bg !< Background isopycnal height diffusivity [L2 T-1 ~> m2 s-1] real :: Kh_eta_vel !< Velocity scale that is multiplied by the grid spacing to give !! the isopycnal height diffusivity [L T-1 ~> m s-1] - real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim]. - real :: kappa_smooth !< Vertical diffusivity used to interpolate more - !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. + real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim] + real :: kappa_smooth !< Vertical diffusivity used to interpolate more sensible values + !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: thickness_diffuse !< If true, interfaces heights are diffused. logical :: use_FGNV_streamfn !< If true, use the streamfunction formulation of !! Ferrari et al., 2010, which effectively emphasizes @@ -798,7 +798,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (use_EOS) then halo = 1 ! Default halo to fill is 1 - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, US, halo, larger_h_denom=.true.) endif ! Rescale the thicknesses, perhaps using the specific volume. @@ -2191,7 +2191,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", CS%use_FGNV_streamfn, & "If true, use the streamfunction formulation of "//& "Ferrari et al., 2010, which effectively emphasizes "//& diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7ec612f141..95e33929df 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -41,7 +41,7 @@ module MOM_int_tide_input real :: TKE_itide_max !< Maximum Internal tide conversion !! available to mix above the BBL [R Z3 T-3 ~> W m-2] real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values - !! of T & S into thin layers [Z2 T-1 ~> m2 s-1]. + !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable, dimension(:,:) :: TKE_itidal_coef !< The time-invariant field that enters the TKE_itidal input calculation [R Z3 T-2 ~> J m-2]. @@ -118,7 +118,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! Smooth the properties through massless layers. if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, US, larger_h_denom=.true.) endif call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot) @@ -352,7 +352,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_fill, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9dc7b81c46..dfd264c92a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -87,7 +87,7 @@ module MOM_set_diffusivity real :: Kd_add !< uniform diffusivity added everywhere without !! filtering or scaling [Z2 T-1 ~> m2 s-1]. real :: Kd_smooth !< Vertical diffusivity used to interpolate more - !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. + !! sensible values of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing logical :: limit_dissipation !< If enabled, dissipation is limited to be larger @@ -274,7 +274,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i integer :: i, j, k, is, ie, js, je, nz, isd, ied, jsd, jed - real :: kappa_dt_fill ! diffusivity times a timestep used to fill massless layers [Z2 ~> m2] + real :: kappa_dt_fill ! diffusivity times a timestep used to fill massless layers [H Z ~> m2 or kg m-1] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -289,7 +289,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%answer_date < 20190101) then ! These hard-coded dimensional parameters are being replaced. - kappa_dt_fill = US%m_to_Z**2 * 1.e-3 * 7200. + kappa_dt_fill = 1.e-3*GV%m2_s_to_HZ_T * 7200.*US%s_to_T else kappa_dt_fill = CS%Kd_smooth * dt endif @@ -340,7 +340,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then call full_convection(G, GV, US, h, tv, T_f, S_f, fluxes%p_surf, & - (GV%Z_to_H**2)*kappa_dt_fill, halo=1) + GV%Z_to_H*kappa_dt_fill, halo=1) call calc_kappa_shear_vertex(u, v, h, T_f, S_f, tv, fluxes%p_surf, visc%Kd_shear, & visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) @@ -380,7 +380,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call hchksum(tv%S, "before vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) call hchksum(h, "before vert_fill_TS h",G%HI, scale=GV%H_to_m) endif - call vert_fill_TS(h, tv%T, tv%S, kappa_dt_fill, T_f, S_f, G, GV, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, kappa_dt_fill, T_f, S_f, G, GV, US, larger_h_denom=.true.) if (CS%debug) then call hchksum(tv%T, "after vert_fill_TS tv%T", G%HI, scale=US%C_to_degC) call hchksum(tv%S, "after vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) @@ -2212,7 +2212,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD_SMOOTH", CS%Kd_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & From e465b1f6f913c97905b9d8aa9d9aec1110154a01 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 26 Jul 2023 04:55:19 -0400 Subject: [PATCH 018/146] Add comment justifying rescaling in vert_fill_TS Added a comment justifying the use of a fixed rescaling factor for the diffusivity used in vert_fill_TS. All answers and output are identical. --- src/core/MOM_isopycnal_slopes.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 73ae8a9816..29c547148d 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -529,6 +529,11 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, US, halo_here, is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke h_neglect = GV%H_subroundoff + ! The use of the fixed rescaling factor in the next line avoids an extra call to thickness_to_dz() + ! and the use of an extra 3-d array of vertical distnaces across layers (dz). This would be more + ! physically consistent, but it would also be more expensive, and given that this routine applies + ! a small (but arbitrary) amount of mixing to clean up the properties of nearly massless layers, + ! the added expense is hard to justify. kap_dt_x2 = (2.0*kappa_dt) * (US%Z_to_m*GV%m_to_H) ! Usually the latter term is GV%Z_to_H. h0 = h_neglect if (present(larger_h_denom)) then From 636d6109b9c14f7c5479dc5514913159d7cd97e3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 18 Jul 2023 05:27:01 -0400 Subject: [PATCH 019/146] +*Add and use find_ustar Added the new public interface find_ustar to extract the friction velocity from either a forcing type argument, or a mech_forcing_type argument, either directly or from tau_mag, and in non-Boussinesq mode by using the time-evolving surface specific volume. Find_ustar is an overloaded interface to find_ustar_fluxes or find_ustar_mech_forcing, which are the same but for the type of one of their arguments. For now, the subroutines bulkmixedlayer, mixedlayer_restrajt_OM4, mixedlayer_restrat_Bodner and mixedlayer_restrat_BML are calling find_ustar to avoid code duplication during the transition to work in fully non-Boussinesq mode, but it will eventually be used in about another half dozen other places. All Boussinesq answers are bitwise identical, but non-Boussinesq answers will change and become less dependent on the Boussinesq reference density, and there is a new publicly visible interface wrapping two subroutines. --- src/core/MOM_forcing_type.F90 | 141 +++++++++++++++++- .../lateral/MOM_mixed_layer_restrat.F90 | 36 +++-- .../vertical/MOM_bulk_mixed_layer.F90 | 19 ++- 3 files changed, 182 insertions(+), 14 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 9623256b88..a6d35903ee 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -29,7 +29,7 @@ module MOM_forcing_type public extractFluxes1d, extractFluxes2d, optics_type public MOM_forcing_chksum, MOM_mech_forcing_chksum -public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d +public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d, find_ustar public forcing_accumulate, fluxes_accumulate public forcing_SinglePointPrint, mech_forcing_diags, forcing_diagnostics public register_forcing_type_diags, allocate_forcing_type, deallocate_forcing_type @@ -53,6 +53,12 @@ module MOM_forcing_type module procedure allocate_mech_forcing_from_ref end interface allocate_mech_forcing +!> Determine the friction velocity from a forcing type or a mechanical forcing type. +interface find_ustar + module procedure find_ustar_fluxes + module procedure find_ustar_mech_forcing +end interface find_ustar + ! 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 @@ -1077,6 +1083,139 @@ subroutine calculateBuoyancyFlux2d(G, GV, US, fluxes, optics, h, Temp, Salt, tv, end subroutine calculateBuoyancyFlux2d +!> Determine the friction velocity from the contenxts of a forcing type, perhaps +!! using the evolving surface density. +subroutine find_ustar_fluxes(fluxes, tv, U_star, G, GV, US, halo, H_T_units) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(forcing), intent(in) :: fluxes !< Surface fluxes container + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: U_star !< The surface friction velocity [Z T-1 ~> m s-1] or + !! [H T-1 ~> m s-1 or kg m-2 s-1], depending on H_T_units. + integer, optional, intent(in) :: halo !< The extra halo size to fill in, 0 by default + logical, optional, intent(in) :: H_T_units !< If present and true, return U_star in units + !! of [H T-1 ~> m s-1 or kg m-2 s-1] + + ! Local variables + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] or in some semi-Boussinesq cases + ! the rescaled reference density [H2 Z-1 L-1 R-1 ~> m3 kg-1 or kg m-3] + logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is + ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] + integer :: i, j, k, is, ie, js, je, hs + + hs = 0 ; if (present(halo)) hs = max(halo, 0) + is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs + + Z_T_units = .true. ; if (present(H_T_units)) Z_T_units = .not.H_T_units + + if (.not.(associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) & + call MOM_error(FATAL, "find_ustar_fluxes requires that either ustar or tau_mag be associated.") + + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = fluxes%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%Z_to_H * fluxes%ustar(i,j) + enddo ; enddo + endif + elseif (allocated(tv%SpV_avg)) then + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_ustar_fluxes called in non-Boussinesq mode with invalid values of SpV_avg.") + if (tv%valid_SpV_halo < hs) call MOM_error(FATAL, & + "find_ustar_fluxes called in non-Boussinesq mode with insufficient valid values of SpV_avg.") + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + enddo ; enddo + endif + else + I_rho = US%L_to_Z * GV%Z_to_H * GV%RZ_to_H + if (Z_T_units) I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(fluxes%tau_mag(i,j) * I_rho) + enddo ; enddo + endif + +end subroutine find_ustar_fluxes + + +!> Determine the friction velocity from the contenxts of a forcing type, perhaps +!! using the evolving surface density. +subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_units) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(mech_forcing), intent(in) :: forces !< Surface forces container + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: U_star !< The surface friction velocity [Z T-1 ~> m s-1] + integer, optional, intent(in) :: halo !< The extra halo size to fill in, 0 by default + logical, optional, intent(in) :: H_T_units !< If present and true, return U_star in units + !! of [H T-1 ~> m s-1 or kg m-2 s-1] + + ! Local variables + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] or in some semi-Boussinesq cases + ! the rescaled reference density [H2 Z-1 L-1 R-1 ~> m3 kg-1 or kg m-3] + logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is + ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] + integer :: i, j, k, is, ie, js, je, hs + + hs = 0 ; if (present(halo)) hs = max(halo, 0) + is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs + + Z_T_units = .true. ; if (present(H_T_units)) Z_T_units = .not.H_T_units + + if (.not.(associated(forces%ustar) .or. associated(forces%tau_mag))) & + call MOM_error(FATAL, "find_ustar_mech requires that either ustar or tau_mag be associated.") + + if (associated(forces%ustar) .and. (GV%Boussinesq .or. .not.associated(forces%tau_mag))) then + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = forces%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%Z_to_H * forces%ustar(i,j) + enddo ; enddo + endif + elseif (allocated(tv%SpV_avg)) then + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_ustar_mech called in non-Boussinesq mode with invalid values of SpV_avg.") + if (tv%valid_SpV_halo < hs) call MOM_error(FATAL, & + "find_ustar_mech called in non-Boussinesq mode with insufficient valid values of SpV_avg.") + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(US%L_to_Z*forces%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%RZ_to_H * sqrt(US%L_to_Z*forces%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + enddo ; enddo + endif + else + I_rho = US%L_to_Z * GV%Z_to_H * GV%RZ_to_H + if (Z_T_units) I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(forces%tau_mag(i,j) * I_rho) + enddo ; enddo + endif + +end subroutine find_ustar_mech_forcing + + !> Write out chksums for thermodynamic fluxes. subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) character(len=*), intent(in) :: mesg !< message diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 206773ecb0..5b7ec60dee 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -11,7 +11,7 @@ module MOM_mixed_layer_restrat use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock -use MOM_forcing_type, only : mech_forcing +use MOM_forcing_type, only : mech_forcing, find_ustar use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_lateral_mixing_coeffs, only : VarMix_CS @@ -184,6 +184,9 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, & ! The wind friction velocity, calculated using + ! the Boussinesq reference density or the time-evolving surface density + ! in non-Boussinesq mode [Z T-1 ~> m s-1] MLD_fast, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] htot_fast, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] Rml_av_fast, & ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] @@ -254,6 +257,9 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "The resolution argument, Rd/dx, was not associated.") + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + if (CS%MLE_density_diff > 0.) then ! We need to calculate a mixed layer depth, MLD. !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA pRef_MLD(:) = 0. @@ -408,7 +414,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, if (CS%debug) then call hchksum(h,'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(forces%ustar,'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) + call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) call hchksum(MLD_fast,'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_m) call hchksum(Rml_av_fast,'mixed_layer_restrat: rml', G%HI, haloshift=1, & scale=US%m_to_Z*US%L_T_to_m_s**2) @@ -421,7 +427,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! U - Component !$OMP do do j=js,je ; do I=is-1,ie - u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f @@ -508,7 +514,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! V- component !$OMP do do J=js-1,je ; do i=is,ie - u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f @@ -711,6 +717,9 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d wpup ! Turbulent vertical momentum [ ????? ~> m2 s-2] real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity, calculated using the Boussinesq + ! reference density or the time-evolving surface density in non-Boussinesq + ! mode [Z T-1 ~> m s-1] real :: covTS(SZI_(G)) ! SGS TS covariance in Stanley param; currently 0 [degC ppt] real :: varS(SZI_(G)) ! SGS S variance in Stanley param; currently 0 [ppt2] real :: dmu(SZK_(GV)) ! Change in mu(z) across layer k [nondim] @@ -762,12 +771,15 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d call pass_var(bflux, G%domain, halo=1) + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + if (CS%debug) then call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_m) call hchksum(BLD, 'mle_Bodner: BLD in', G%HI, haloshift=1, scale=US%Z_to_m) if (associated(bflux)) & call hchksum(bflux, 'mle_Bodner: bflux', G%HI, haloshift=1, scale=US%Z_to_m**2*US%s_to_T**3) - call hchksum(forces%ustar,'mle_Bodner: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) + call hchksum(U_star_2d, 'mle_Bodner: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) call hchksum(CS%MLD_filtered, 'mle_Bodner: MLD_filtered 1', & G%HI, haloshift=1, scale=US%Z_to_m) call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 1', & @@ -793,7 +805,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d do j = js-1, je+1 ; do i = is-1, ie+1 w_star3 = max(0., -bflux(i,j)) * BLD(i,j) & ! (this line in Z3 T-3 ~> m3 s-3) * ( ( US%Z_to_m * US%s_to_T )**3 ) ! m3 s-3 - u_star3 = ( US%Z_to_m * US%s_to_T * forces%ustar(i,j) )**3 ! m3 s-3 + u_star3 = ( US%Z_to_m * US%s_to_T * U_star_2d(i,j) )**3 ! m3 s-3 wpup(i,j) = max( CS%min_wstar2, & ! The max() avoids division by zero later ( CS%mstar * u_star3 + CS%nstar * w_star3 )**two_thirds ) & ! (this line m2 s-2) * ( ( US%m_to_Z * US%T_to_s )**2 ) ! Z2 T-2 ~> m2 s-2 @@ -965,7 +977,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! Offer diagnostic fields for averaging. if (query_averaging_enabled(CS%diag)) then - if (CS%id_ustar > 0) call post_data(CS%id_ustar, forces%ustar, CS%diag) + if (CS%id_ustar > 0) call post_data(CS%id_ustar, U_star_2d, CS%diag) if (CS%id_bflux > 0) call post_data(CS%id_bflux, bflux, CS%diag) if (CS%id_wpup > 0) call post_data(CS%id_wpup, wpup, CS%diag) if (CS%id_Rml > 0) call post_data(CS%id_Rml, buoy_av, CS%diag) @@ -1053,6 +1065,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, & ! The wind friction velocity, calculated using + ! the Boussinesq reference density or the time-evolving surface density + ! in non-Boussinesq mode [Z T-1 ~> m s-1] htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] Rml_av ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] @@ -1110,6 +1125,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) if (CS%use_Stanley_ML) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & "The Stanley parameterization is not available with the BML.") + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + ! Fix this later for nkml >= 3. p0(:) = 0.0 @@ -1145,7 +1163,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) do j=js,je ; do I=is-1,ie h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z - u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) @@ -1196,7 +1214,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) do J=js-1,je ; do i=is,ie h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z - u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 66e2dfa6b2..ceba8dad1a 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -9,7 +9,7 @@ module MOM_bulk_mixed_layer use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : extractFluxes1d, forcing +use MOM_forcing_type, only : extractFluxes1d, forcing, find_ustar use MOM_grid, only : ocean_grid_type use MOM_opacity, only : absorbRemainingSW, optics_type, extract_optics_slice use MOM_unit_scaling, only : unit_scale_type @@ -235,6 +235,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ksort ! The sorted k-index that each original layer goes to. real, dimension(SZI_(G),SZJ_(G)) :: & h_miss ! The summed absolute mismatch [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(G)) :: & TKE, & ! The turbulent kinetic energy available for mixing over a ! time step [Z L2 T-2 ~> m3 s-2]. @@ -412,6 +415,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C max_BL_det(:) = -1 EOSdom(:) = EOS_domain(G%HI) + ! Extract the friction velocity from the forcing type. + call find_ustar(fluxes, tv, U_star_2d, G, GV, US) + !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,Rcv,ksort, & !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,htot,Ttot,Stot,TKE,Conv_en, & @@ -513,7 +519,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! First the TKE at the depth of free convection that is available ! to drive mixing is calculated. - call find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & + call find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & j, ksort, G, GV, US, CS) @@ -1252,7 +1258,7 @@ end subroutine mixedlayer_convection !> This subroutine determines the TKE available at the depth of free !! convection to drive mechanical entrainment. -subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & +subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & j, ksort, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1265,6 +1271,10 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, type(forcing), intent(in) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields !! have NULL pointers. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: U_star_2d !< The wind friction velocity, calculated + !! using the Boussinesq reference density or + !! the time-evolving surface density in + !! non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(G)), intent(inout) :: Conv_En !< The buoyant turbulent kinetic energy source !! due to free convection [Z L2 T-2 ~> m3 s-2]. real, dimension(SZI_(G)), intent(in) :: dKE_FC !< The vertically integrated change in @@ -1325,7 +1335,8 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, if (CS%omega_frac >= 1.0) absf = 2.0*CS%omega do i=is,ie - U_star = fluxes%ustar(i,j) + U_star = U_star_2d(i,j) + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then if (fluxes%frac_shelf_h(i,j) > 0.0) & U_star = (1.0 - fluxes%frac_shelf_h(i,j)) * U_star + & From 878fd1ef671456a804c598df606e4cf7c803c203 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 24 Jul 2023 14:14:29 -0400 Subject: [PATCH 020/146] +wave_speed arg mono_N2_depth in thickness units Changed the units of the optional mono_N2_depth argument to wave_speed, wave_speed_init and wave_speed_set_param in thickness units instead of height units. Accordingly, the units of one element each in the diagnostics_CS and wave_speed_CS and a local variable in VarMix_init are also changed to thickness units. The unit descriptions of some comments describing diagnostics were also amended to also describe the non-Boussinesq versions. Because this is essentially just changing when the unit conversion occurs, all answers are bitwise identical, but there are changes to the units of an optional argument in 3 publicly visible routines. --- src/diagnostics/MOM_diagnostics.F90 | 24 +++---- src/diagnostics/MOM_wave_speed.F90 | 64 ++++++++++--------- .../lateral/MOM_lateral_mixing_coeffs.F90 | 4 +- 3 files changed, 49 insertions(+), 43 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index cf8b042c14..157c7268bf 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -56,7 +56,7 @@ module MOM_diagnostics !! monotonic for the purposes of calculating the equivalent !! barotropic wave speed [nondim]. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed [Z ~> m]. + !! calculating the equivalent barotropic wave speed [H ~> m or kg m-2]. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -984,7 +984,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_dKEdt > 0) then - ! Calculate the time derivative of the layer KE [H L2 T-3 ~> m3 s-3]. + ! Calculate the time derivative of the layer KE [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * CS%du_dt(I,j,k) @@ -1006,7 +1006,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_PE_to_KE > 0) then - ! Calculate the potential energy to KE term [H L2 T-3 ~> m3 s-3]. + ! Calculate the potential energy to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%PFu(I,j,k) @@ -1025,7 +1025,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_BT > 0) then - ! Calculate the barotropic contribution to KE term [H L2 T-3 ~> m3 s-3]. + ! Calculate the barotropic contribution to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%u_accel_bt(I,j,k) @@ -1044,7 +1044,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_Coradv > 0) then - ! Calculate the KE source from the combined Coriolis and advection terms [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from the combined Coriolis and advection terms [H L2 T-3 ~> m3 s-3 or W m-2]. ! The Coriolis source should be zero, but is not due to truncation errors. There should be ! near-cancellation of the global integral of this spurious Coriolis source. do k=1,nz @@ -1069,7 +1069,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_adv > 0) then - ! Calculate the KE source from along-layer advection [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from along-layer advection [H L2 T-3 ~> m3 s-3 or W m-2]. ! NOTE: All terms in KE_adv are multiplied by -1, which can easily produce ! negative zeros and may signal a reproducibility issue over land. ! We resolve this by re-initializing and only evaluating over water points. @@ -1098,7 +1098,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_visc > 0) then - ! Calculate the KE source from vertical viscosity [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from vertical viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc(I,j,k) @@ -1117,7 +1117,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_visc_gl90 > 0) then - ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) @@ -1136,7 +1136,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_stress > 0) then - ! Calculate the KE source from surface stress (included in KE_visc) [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from surface stress (included in KE_visc) [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_str(I,j,k) @@ -1155,7 +1155,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_horvisc > 0) then - ! Calculate the KE source from horizontal viscosity [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from horizontal viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%diffu(I,j,k) @@ -1174,7 +1174,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_dia > 0) then - ! Calculate the KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_dia(I,j,k) @@ -1594,7 +1594,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_DEPTH", CS%mono_N2_depth, & "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & - units='m', scale=US%m_to_Z, default=-1.) + units='m', scale=GV%m_to_H, default=-1.) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & "The fractional tolerance for finding the wave speeds.", & units="nondim", default=0.001) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 5757e25cd1..c2b671f1c6 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -38,7 +38,7 @@ module MOM_wave_speed !! wave speed [nondim]. This parameter controls the default behavior of !! wave_speed() which can be overridden by optional arguments. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed [Z ~> m]. + !! calculating the equivalent barotropic wave speed [H ~> m or kg m-2]. !! If this parameter is negative, this limiting does not occur. !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. @@ -81,7 +81,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !! for the purposes of calculating vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as !! monotonic for the purposes of calculating vertical - !! modal structure [Z ~> m]. + !! modal structure [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: modal_structure !< Normalized model structure [nondim] @@ -157,9 +157,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: sum_hc ! The sum of the layer thicknesses [Z ~> m] real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] real :: N2min ! A minimum buoyancy frequency, including a slope rescaling factor [L2 Z-2 T-2 ~> s-2] + logical :: below_mono_N2_frac ! True if an interface is below the fractional depth where N2 should not increase. + logical :: below_mono_N2_depth ! True if an interface is below the absolute depth where N2 should not increase. logical :: l_use_ebt_mode, calc_modal_structure real :: l_mono_N2_column_fraction ! A local value of mono_N2_column_fraction [nondim] - real :: l_mono_N2_depth ! A local value of mono_N2_column_depth [Z ~> m] + real :: l_mono_N2_depth ! A local value of mono_N2_column_depth [H ~> m or kg m-2] real :: mode_struct(SZK_(GV)) ! The mode structure [nondim], but it is also temporarily ! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6. real :: ms_min, ms_max ! The minimum and maximum mode structure values returned from tdma6 [L2 T-2 ~> m2 s-2] @@ -214,18 +216,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. min_h_frac = tol_Hfrac / real(nz) -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,tv,& -!$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & -!$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale, & -!$OMP better_est,cg1_min2,tol_merge,tol_solve,c2_scale) & -!$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & -!$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT,drho_dS, & -!$OMP drxh_sum,kc,Hc,Hc_H,Tc,Sc,I_Hnew,gprime,& -!$OMP Rc,speed2_tot,Igl,Igu,lam0,lam,lam_it,dlam, & -!$OMP mode_struct,sum_hc,N2min,gp,hw, & -!$OMP ms_min,ms_max,ms_sq,H_top,H_bot,I_Htot,merge, & -!$OMP det,ddet,det_it,ddet_it) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,tv,use_EOS, & + !$OMP CS,min_h_frac,calc_modal_structure,l_use_ebt_mode, & + !$OMP modal_structure,l_mono_N2_column_fraction,l_mono_N2_depth, & + !$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,cg1_min2, & + !$OMP better_est,tol_solve,tol_merge,c2_scale) 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 @@ -335,7 +330,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * max(0.0,Rf(k,i)-Rf(k-1,i)) enddo endif - endif + endif ! use_EOS ! Find gprime across each internal interface, taking care of convective instabilities by ! merging layers. If the estimated wave speed is too small, simply return zero. @@ -452,24 +447,34 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ Igu(1) = 0. ! Neumann condition for pressure modes sum_hc = Hc(1) N2min = gprime(2)/Hc(1) + + below_mono_N2_frac = .false. + below_mono_N2_depth = .false. do k=2,kc hw = 0.5*(Hc(k-1)+Hc(k)) gp = gprime(K) if (l_mono_N2_column_fraction>0. .or. l_mono_N2_depth>=0.) then - !### Change to: if ( ((htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) .or. & ) ) - if ( (((G%bathyT(i,j)+G%Z_ref) - sum_hc < l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) .or. & - ((l_mono_N2_depth >= 0.) .and. (sum_hc > l_mono_N2_depth))) .and. & - (gp > N2min*hw) ) then - ! Filters out regions where N2 increases with depth but only in a lower fraction + ! Determine whether N2 estimates should not be allowed to increase with depth. + if (l_mono_N2_column_fraction>0.) then + !### Change to: (htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) + below_mono_N2_frac = ((G%bathyT(i,j)+G%Z_ref) - GV%H_to_Z*sum_hc < & + l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) + endif + if (l_mono_N2_depth >= 0.) below_mono_N2_depth = (sum_hc > GV%H_to_Z*l_mono_N2_depth) + + if ( (gp > N2min*hw) .and. (below_mono_N2_frac .or. below_mono_N2_depth) ) then + ! Filters out regions where N2 increases with depth, but only in a lower fraction ! of the water column or below a certain depth. gp = N2min * hw else N2min = gp / hw endif endif + Igu(k) = 1.0/(gp*Hc(k)) Igl(k-1) = 1.0/(gp*Hc(k-1)) sum_hc = sum_hc + Hc(k) + if (better_est) then ! Estimate that the ebt_mode is sqrt(2) times the speed of the flat bottom modes. speed2_tot = speed2_tot + 2.0 * gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) @@ -690,7 +695,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] gprime, & ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. - N2 ! The Brunt Vaissalla freqency squared [T-2 ~> s-2] + N2 ! The buoyancy freqency squared [T-2 ~> s-2] real, dimension(SZK_(GV),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [C ~> degC] @@ -704,7 +709,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s Sc, & ! A column of layer salinities after convective instabilities are removed [S ~> ppt] Rc, & ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] - real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] + real :: I_Htot ! The inverse of the total filtered thicknesses [Z-1 ~> m-1] real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and its ! derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. ! The exact value should not matter for the final result if it is an even power of 2. @@ -797,6 +802,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! Simplifying the following could change answers at roundoff. Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) use_EOS = associated(tv%eqn_of_state) + if (CS%c1_thresh < 0.0) & call MOM_error(FATAL, "INTERNAL_WAVE_CG1_THRESH must be set to a non-negative "//& "value via wave_speed_init for wave_speeds to be used.") @@ -978,7 +984,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s I_Hnew = 1.0 / (Hc(kc) + Hc(kc-1)) Tc(kc-1) = (Hc(kc)*Tc(kc) + Hc(kc-1)*Tc(kc-1)) * I_Hnew Sc(kc-1) = (Hc(kc)*Sc(kc) + Hc(kc-1)*Sc(kc-1)) * I_Hnew - Hc(kc-1) = (Hc(kc) + Hc(kc-1)) + Hc(kc-1) = Hc(kc) + Hc(kc-1) kc = kc - 1 else ; exit ; endif enddo @@ -1006,7 +1012,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s if (merge) then ! Merge this layer with the one above and backtrack. Rc(kc) = (Hc(kc)*Rc(kc) + Hf(k,i)*Rf(k,i)) / (Hc(kc) + Hf(k,i)) - Hc(kc) = (Hc(kc) + Hf(k,i)) + Hc(kc) = Hc(kc) + Hf(k,i) ! Backtrack to remove any convective instabilities above... Note ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. @@ -1019,7 +1025,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s if (merge) then ! Merge the two bottommost layers. At this point kc = k2. Rc(kc-1) = (Hc(kc)*Rc(kc) + Hc(kc-1)*Rc(kc-1)) / (Hc(kc) + Hc(kc-1)) - Hc(kc-1) = (Hc(kc) + Hc(kc-1)) + Hc(kc-1) = Hc(kc) + Hc(kc-1) kc = kc - 1 else ; exit ; endif enddo @@ -1109,7 +1115,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s do k=1,kc w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) ![Z L4 T-4] enddo - renorm = sqrt(htot(i)*a_int/w2avg) ![L-2 T-2] + renorm = sqrt(htot(i)*a_int/w2avg) ! [T2 L-2] do K=1,kc+1 ; mode_struct(K) = renorm * mode_struct(K) ; enddo ! after renorm, mode_struct is again [nondim] @@ -1437,7 +1443,7 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! calculating the vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure [Z ~> m]. + !! vertical modal structure [H ~> m or kg m-2]. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions !! that recover the remapping answers from 2018. Otherwise !! use more robust but mathematically equivalent expressions. @@ -1489,7 +1495,7 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ !! calculating the vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure [Z ~> m]. + !! vertical modal structure [H ~> m or kg m-2]. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions !! that recover the remapping answers from 2018. Otherwise !! use more robust but mathematically equivalent expressions. diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e74e48055a..df26f3f6a4 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1103,7 +1103,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) real :: oneOrTwo ! A variable that may be 1 or 2, depending on which form ! of the equatorial deformation radius us used [nondim] real :: N2_filter_depth ! A depth below which stratification is treated as monotonic when - ! calculating the first-mode wave speed [Z ~> m] + ! calculating the first-mode wave speed [H ~> m or kg m-2] real :: KhTr_passivity_coeff ! Coefficient setting the ratio between along-isopycnal tracer ! mixing and interface height mixing [nondim] real :: absurdly_small_freq ! A miniscule frequency that is used to avoid division by 0 [T-1 ~> s-1]. The @@ -1241,7 +1241,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "The depth below which N2 is monotonized to avoid stratification "//& "artifacts from altering the equivalent barotropic mode structure. "//& "This monotonzization is disabled if this parameter is negative.", & - units="m", default=-1.0, scale=US%m_to_Z) + units="m", default=-1.0, scale=GV%m_to_H) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif From be5602e1b91b0d4772b1619ac5be6df6020ab921 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 19 Jul 2023 09:23:57 -0400 Subject: [PATCH 021/146] *+Add BT_RHO_LINEARIZED to MOM_barotropic.F90 Added the new runtime parameter BT_RHO_LINEARIZED to specify the density that is used to convert total water column thicknesses into mass in non-Boussinesq mode with linearized options in the barotropic solver or when estimating the stable barotropic timestep without access to the full baroclinic model state. The default is set to RHO_0 and answers do not change by default. This new parameter is used in non-Boussinesq mode with some options in btcalc and find_face_areas, when LINEARIZED_BT_CORIOLIS = True or BT_NONLIN_STRESS = False, and in the unit conversion of the ice strength with dynamic pressure. Also cancelled out factors of GV%Z_to_H in MOM_barotropic.F90 to simplify the code and reduce the dependence on the value of GV%Rho_0 in non-Boussinesq mode. This involved changing the units of 4 variables in the barotropic_CS type, 3 internal variables in btstep and an internal variable in barotropic_init to use thickness units. The rescaled internal variable mass_to_Z was also replaced with the equivalent GV%RZ_to_H. There are also 4 new debugging messages. Also modified the units of the gtot_est argument to match those of pbce. There is a new element in barotropic_CS. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode. Additionally there is a new runtime parameter that will appear in some MOM_parameter_doc files. --- src/core/MOM_barotropic.F90 | 193 ++++++++++++++++++++++-------------- 1 file changed, 118 insertions(+), 75 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 40f759f4b8..adbbd3b4dd 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -3,8 +3,9 @@ module MOM_barotropic ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : hchksum, uvchksum +use MOM_checksums, only : chksum0 use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl, enable_averaging, enable_averages use MOM_domains, only : min_across_PEs, clone_MOM_domain, deallocate_MOM_domain @@ -105,7 +106,7 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: frhatv !< The fraction of the total column thickness interpolated to v grid points in each layer [nondim]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: IDatu - !< Inverse of the basin depth at u grid points [Z-1 ~> m-1]. + !< Inverse of the total thickness at u grid points [H-1 ~> m-1 or m2 kg-1]. 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]. @@ -139,11 +140,11 @@ module MOM_barotropic !< This is a copy of G%IareaT with wide halos, but will !! still utilize the macro IareaT when referenced, [L-2 ~> m-2]. real ALLOCABLE_, dimension(NIMEMBW_,NJMEMW_) :: & - D_u_Cor, & !< A simply averaged depth at u points [Z ~> m]. + D_u_Cor, & !< A simply averaged depth at u points recast as a thickness [H ~> m or kg m-2] dy_Cu, & !< A copy of G%dy_Cu with wide halos [L ~> m]. IdxCu !< A copy of G%IdxCu with wide halos [L-1 ~> m-1]. real ALLOCABLE_, dimension(NIMEMW_,NJMEMBW_) :: & - D_v_Cor, & !< A simply averaged depth at v points [Z ~> m]. + D_v_Cor, & !< A simply averaged depth at v points recast as a thickness [H ~> m or kg m-2] dx_Cv, & !< A copy of G%dx_Cv with wide halos [L ~> m]. IdyCv !< A copy of G%IdyCv with wide halos [L-1 ~> m-1]. real ALLOCABLE_, dimension(NIMEMBW_,NJMEMBW_) :: & @@ -170,6 +171,10 @@ module MOM_barotropic !! 0.0 gives a forward-backward scheme, while 1.0 !! give backward Euler. In practice, bebt should be !! of order 0.2 or greater. + real :: Rho_BT_lin !< A density that is used to convert total water column thicknesses + !! into mass in non-Boussinesq mode with linearized options in the + !! barotropic solver or when estimating the stable barotropic timestep + !! without access to the full baroclinic model state [R ~> kg m-3] logical :: split !< If true, use the split time stepping scheme. logical :: bound_BT_corr !< If true, the magnitude of the fake mass source !! in the barotropic equation that drives the two @@ -216,8 +221,8 @@ module MOM_barotropic logical :: dynamic_psurf !< If true, add a dynamic pressure due to a viscous !! ice shelf, for instance. - real :: Dmin_dyn_psurf !< The minimum depth to use in limiting the size - !! of the dynamic surface pressure for stability [Z ~> m]. + real :: Dmin_dyn_psurf !< The minimum total thickness to use in limiting the size + !! of the dynamic surface pressure for stability [H ~> m or kg m-2]. real :: ice_strength_length !< The length scale at which the damping rate !! due to the ice strength should be the same as if !! a Laplacian were applied [L ~> m]. @@ -511,8 +516,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. ! These are always allocated with symmetric memory and wide halos. - real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 Z-1 ~> s-1 m-1] - ! or [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] + real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] real, dimension(SZIBW_(CS),SZJW_(CS)) :: & ubt, & ! The zonal barotropic velocity [L T-1 ~> m s-1]. bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains @@ -545,7 +549,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Rayleigh_u, & ! A Rayleigh drag timescale operating at u-points [T-1 ~> s-1]. PFu_bt_sum, & ! The summed zonal barotropic pressure gradient force [L T-2 ~> m s-2]. Coru_bt_sum, & ! The summed zonal barotropic Coriolis acceleration [L T-2 ~> m s-2]. - DCor_u, & ! An averaged depth or total thickness at u points [Z ~> m] or [H ~> m or kg m-2]. + DCor_u, & ! An averaged total thickness at u points [H ~> m or kg m-2]. Datu ! Basin depth at u-velocity grid points times the y-grid ! spacing [H L ~> m2 or kg m-1]. real, dimension(SZIW_(CS),SZJBW_(CS)) :: & @@ -578,7 +582,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! [L T-2 ~> m s-2]. Corv_bt_sum, & ! The summed meridional barotropic Coriolis acceleration, ! [L T-2 ~> m s-2]. - DCor_v, & ! An averaged depth or total thickness at v points [Z ~> m] or [H ~> m or kg m-2]. + DCor_v, & ! An averaged total thickness at v points [H ~> m or kg m-2]. Datv ! Basin depth at v-velocity grid points times the x-grid ! spacing [H L ~> m2 or kg m-1]. real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & @@ -626,7 +630,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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 inverse of the 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]. real :: dtbt ! The barotropic time step [T ~> s]. @@ -664,6 +667,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: dyn_coef_max ! The maximum stable value of dyn_coef_eta ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real :: ice_strength = 0.0 ! The effective strength of the ice [L2 Z-1 T-2 ~> m s-2]. + real :: H_to_Z ! A local unit conversion factor used with rigid ice [Z H-1 ~> nondim or m3 kg-1] real :: Idt_max2 ! The squared inverse of the local maximum stable ! barotropic time step [T-2 ~> s-2]. real :: H_min_dyn ! The minimum depth to use in limiting the size of the @@ -778,7 +782,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil nstep = CEILING(dt/CS%dtbt - 0.0001) - if (is_root_PE() .and. (nstep /= CS%nstep_last)) then + if (is_root_PE() .and. ((nstep /= CS%nstep_last) .or. CS%debug)) then write(mesg,'("btstep is using a dynamic barotropic timestep of ", ES12.6, & & " seconds, max ", ES12.6, ".")') (US%T_to_s*dt/nstep), US%T_to_s*CS%dtbt_max call MOM_mesg(mesg, 3) @@ -791,7 +795,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Idtbt = 1.0 / dtbt bebt = CS%bebt be_proj = CS%bebt - mass_to_Z = 1.0 / GV%Rho0 !--- setup the weight when computing vbt_trans and ubt_trans if (project_velocity) then @@ -1275,17 +1278,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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) = GV%Z_to_H * CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & + 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) = GV%Z_to_H * CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & + 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) = GV%Z_to_H / Htot_avg + CS%IDatu(I,j) = 1.0 / Htot_avg endif endif - BT_force_u(I,j) = forces%taux(I,j) * mass_to_Z * CS%IDatu(I,j)*visc_rem_u(I,j,1) + BT_force_u(I,j) = forces%taux(I,j) * GV%RZ_to_H * CS%IDatu(I,j)*visc_rem_u(I,j,1) else BT_force_u(I,j) = 0.0 endif ; enddo ; enddo @@ -1301,28 +1304,28 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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) = GV%Z_to_H * CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & + 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) = GV%Z_to_H * CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & + 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) = GV%Z_to_H / Htot_avg + CS%IDatv(i,J) = 1.0 / Htot_avg endif endif - BT_force_v(i,J) = forces%tauy(i,J) * mass_to_Z * CS%IDatv(i,J)*visc_rem_v(i,J,1) + BT_force_v(i,J) = forces%tauy(i,J) * GV%RZ_to_H * CS%IDatv(i,J)*visc_rem_v(i,J,1) else BT_force_v(i,J) = 0.0 endif ; enddo ; enddo if (associated(taux_bot) .and. associated(tauy_bot)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then - BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) + BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * GV%RZ_to_H * CS%IDatu(I,j) endif ; enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then - BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) + BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * GV%RZ_to_H * CS%IDatv(i,J) endif ; enddo ; enddo endif @@ -1595,10 +1598,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%dynamic_psurf) then ice_is_rigid = (associated(forces%rigidity_ice_u) .and. & associated(forces%rigidity_ice_v)) - H_min_dyn = GV%Z_to_H * CS%Dmin_dyn_psurf + H_min_dyn = CS%Dmin_dyn_psurf if (ice_is_rigid .and. use_BT_cont) & call BT_cont_to_face_areas(BT_cont, Datu, Datv, G, US, MS, halo=0) if (ice_is_rigid) then + if (GV%Boussinesq) then + H_to_Z = GV%H_to_Z + else + H_to_Z = GV%H_to_RZ / CS%Rho_BT_lin + endif !$OMP parallel do default(shared) private(Idt_max2,H_eff_dx2,dyn_coef_max,ice_strength) do j=js,je ; do i=is,ie ! First determine the maximum stable value for dyn_coef_eta. @@ -1626,7 +1634,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (CS%ice_strength_length**2 * dtbt) ! Units of dyn_coef: [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1] - dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * GV%H_to_Z) + dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * H_to_Z) enddo ; enddo ; endif endif @@ -1681,9 +1689,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, symmetric=.true., omit_corners=.true., scalar_pair=.true.) call uvchksum("BT frhat[uv]", CS%frhatu, CS%frhatv, G%HI, haloshift=0, & symmetric=.true., omit_corners=.true., scalar_pair=.true.) + call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true.) call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, scale=US%L_T2_to_m_s2) call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, & - scale=US%m_to_Z, scalar_pair=.true.) + scale=GV%m_to_H, scalar_pair=.true.) call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, & haloshift=1, scalar_pair=.true.) endif @@ -2772,7 +2782,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) !! the effective open face areas as a !! function of barotropic flow. real, optional, intent(in) :: gtot_est !< An estimate of the total gravitational - !! acceleration [L2 Z-1 T-2 ~> m s-2]. + !! acceleration [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. real, optional, intent(in) :: SSH_add !< An additional contribution to SSH to !! provide a margin of error when !! calculating the external wave speed [Z ~> m]. @@ -2817,6 +2827,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke MS%isdw = G%isd ; MS%iedw = G%ied ; MS%jsdw = G%jsd ; MS%jedw = G%jed + if (.not.(present(pbce) .or. present(gtot_est))) call MOM_error(FATAL, & "set_dtbt: Either pbce or gtot_est must be present.") @@ -2853,8 +2864,8 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) enddo ; enddo ; enddo else do j=js,je ; do i=is,ie - gtot_E(i,j) = gtot_est * GV%H_to_Z ; gtot_W(i,j) = gtot_est * GV%H_to_Z - gtot_N(i,j) = gtot_est * GV%H_to_Z ; gtot_S(i,j) = gtot_est * GV%H_to_Z + gtot_E(i,j) = gtot_est ; gtot_W(i,j) = gtot_est + gtot_N(i,j) = gtot_est ; gtot_S(i,j) = gtot_est enddo ; enddo endif @@ -2876,6 +2887,12 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) CS%dtbt = CS%dtbt_fraction * dtbt_max CS%dtbt_max = dtbt_max + + if (CS%debug) then + call chksum0(CS%dtbt, "End set_dtbt dtbt", scale=US%T_to_s) + call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", scale=US%T_to_s) + endif + end subroutine set_dtbt !> The following 4 subroutines apply the open boundary conditions. @@ -3342,6 +3359,7 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) ! around a u-point (positive upward) [H ~> m or kg m-2] real :: D_shallow_v(SZIB_(G))! The height of the shallower of the adjacent bathymetric depths ! around a v-point (positive upward) [H ~> m or kg m-2] + real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3] real :: htot ! The sum of the layer thicknesses [H ~> m or kg m-2]. real :: Ihtot ! The inverse of htot [H-1 ~> m-1 or m2 kg-1]. @@ -3383,9 +3401,9 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) ! This estimates the fractional thickness of each layer at the velocity ! points, using a harmonic mean estimate. -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) & -!$OMP private(hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith) + !$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) & + !$OMP private(hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith,Z_to_H) do j=js,je if (present(h_u)) then do I=is-1,ie ; hatutot(I) = h_u(I,j,1) ; enddo @@ -3407,9 +3425,10 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) hatutot(I) = hatutot(I) + CS%frhatu(I,j,k) enddo ; enddo elseif (CS%hvel_scheme == HYBRID .or. use_default) then + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin do I=is-1,ie - e_u(I,nz+1) = -0.5 * GV%Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j)) - D_shallow_u(I) = -GV%Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j)) + e_u(I,nz+1) = -0.5 * Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j)) + D_shallow_u(I) = -Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j)) hatutot(I) = 0.0 enddo do k=nz,1,-1 ; do I=is-1,ie @@ -3447,8 +3466,8 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) endif enddo -!$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) & -!$OMP private(hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith) + !$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) & + !$OMP private(hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith,Z_to_H) do J=js-1,je if (present(h_v)) then do i=is,ie ; hatvtot(i) = h_v(i,J,1) ; enddo @@ -3470,9 +3489,10 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) hatvtot(i) = hatvtot(i) + CS%frhatv(i,J,k) enddo ; enddo elseif (CS%hvel_scheme == HYBRID .or. use_default) then + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin do i=is,ie - e_v(i,nz+1) = -0.5 * GV%Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j)) - D_shallow_v(I) = -GV%Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j)) + e_v(i,nz+1) = -0.5 * Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j)) + D_shallow_v(I) = -Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j)) hatvtot(I) = 0.0 enddo do k=nz,1,-1 ; do i=is,ie @@ -4140,23 +4160,23 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) ! Local variables real :: H1, H2 ! Temporary total thicknesses [H ~> m or kg m-2]. + real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3] integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = max(halo,0) -!$OMP parallel default(none) shared(is,ie,js,je,hs,eta,GV,G,CS,Datu,Datv,add_max) & -!$OMP private(H1,H2) + !$OMP parallel default(shared) private(H1,H2,Z_to_H) if (present(eta)) then ! The use of harmonic mean thicknesses ensure positive definiteness. if (GV%Boussinesq) then -!$OMP do + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) Datu(I,j) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) Datv(i,J) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & @@ -4164,14 +4184,14 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2) enddo ; enddo else -!$OMP do + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs Datu(I,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i+1,j) > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * eta(i,j) * eta(i+1,j)) / & (eta(i,j) + eta(i+1,j)) ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (eta(i,j) + eta(i+1,j)) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs Datv(i,J) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i,j+1) > 0.0)) & Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * eta(i,j) * eta(i,j+1)) / & @@ -4180,33 +4200,37 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) enddo ; enddo endif elseif (present(add_max)) then -!$OMP do + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs - Datu(I,j) = CS%dy_Cu(I,j) * GV%Z_to_H * & + Datu(I,j) = CS%dy_Cu(I,j) * Z_to_H * & max(max(CS%bathyT(i+1,j), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs - Datv(i,J) = CS%dx_Cv(i,J) * GV%Z_to_H * & + Datv(i,J) = CS%dx_Cv(i,J) * Z_to_H * & max(max(CS%bathyT(i,j+1), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0) enddo ; enddo else -!$OMP do + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs - H1 = (CS%bathyT(i,j) + G%Z_ref) * GV%Z_to_H ; H2 = (CS%bathyT(i+1,j) + G%Z_ref) * GV%Z_to_H + H1 = (CS%bathyT(i,j) + G%Z_ref) * Z_to_H ; H2 = (CS%bathyT(i+1,j) + G%Z_ref) * Z_to_H Datu(I,j) = 0.0 if ((H1 > 0.0) .and. (H2 > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs - H1 = (CS%bathyT(i,j) + G%Z_ref) * GV%Z_to_H ; H2 = (CS%bathyT(i,j+1) + G%Z_ref) * GV%Z_to_H + H1 = (CS%bathyT(i,j) + G%Z_ref) * Z_to_H ; H2 = (CS%bathyT(i,j+1) + G%Z_ref) * Z_to_H Datv(i,J) = 0.0 if ((H1 > 0.0) .and. (H2 > 0.0)) & Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2) enddo ; enddo endif -!$OMP end parallel + !$OMP end parallel end subroutine find_face_areas @@ -4306,13 +4330,14 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, character(len=40) :: mdl = "MOM_barotropic" ! This module's name. real :: Datu(SZIBS_(G),SZJ_(G)) ! Zonal open face area [H L ~> m2 or kg m-1]. real :: Datv(SZI_(G),SZJBS_(G)) ! Meridional open face area [H L ~> m2 or kg m-1]. - real :: gtot_estimate ! Summed GV%g_prime [L2 Z-1 T-2 ~> m s-2], to give an upper-bound estimate for pbce. + real :: gtot_estimate ! Summed GV%g_prime [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2], to give an + ! upper-bound estimate for pbce. real :: SSH_extra ! An estimate of how much higher SSH might get, for use ! in calculating the safe external wave speed [Z ~> m]. real :: dtbt_input ! The input value of DTBT, [nondim] if negative or [s] if positive. real :: dtbt_tmp ! A temporary copy of CS%dtbt read from a restart file [T ~> s] real :: wave_drag_scale ! A scaling factor for the barotropic linear wave drag - ! piston velocities. + ! piston velocities [nondim]. character(len=200) :: inputdir ! The directory in which to find input files. character(len=200) :: wave_drag_file ! The file from which to read the wave ! drag piston velocity. @@ -4320,11 +4345,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! name in wave_drag_file. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. + real :: Z_to_H ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3] + real :: H_to_Z ! A local unit conversion factor [Z H-1 ~> nondim or m3 kg-1] real :: det_de ! The partial derivative due to self-attraction and loading of the reference ! geopotential with the sea surface height when tides are enabled [nondim]. ! This is typically ~0.09 or less. real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points - ! that acts on the barotropic flow [Z T-1 ~> m s-1]. + ! that acts on the barotropic flow [H T-1 ~> m s-1 or kg m-2 s-1]. type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor @@ -4444,6 +4471,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "If true, use the full depth of the ocean at the start of the barotropic "//& "step when calculating the surface stress contribution to the barotropic "//& "acclerations. Otherwise use the depth based on bathyT.", default=.false.) + call get_param(param_file, mdl, "BT_RHO_LINEARIZED", CS%Rho_BT_lin, & + "A density that is used to convert total water column thicknesses into mass "//& + "in non-Boussinesq mode with linearized options in the barotropic solver or "//& + "when estimating the stable barotropic timestep without access to the full "//& + "baroclinic model state.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=GV%Boussinesq) call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & "If true, add a dynamic pressure due to a viscous ice "//& @@ -4457,7 +4491,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "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) + units="m", default=1.0e-6, scale=GV%m_to_H, 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 "//& @@ -4471,20 +4505,23 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "BAROTROPIC_2018_ANSWERS", answers_2018, & "If true, use expressions for the barotropic solver that recover the answers "//& "from the end of 2018. Otherwise, use more efficient or general expressions.", & - default=default_2018_answers) + default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions in the barotropic solver. "//& "Values below 20190101 recover the answers from the end of 2018, "//& "while higher values uuse more efficient or general expressions. "//& "If both BAROTROPIC_2018_ANSWERS and BAROTROPIC_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) @@ -4729,21 +4766,23 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ALLOC_(CS%D_v_Cor(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) CS%q_D(:,:) = 0.0 ; CS%D_u_Cor(:,:) = 0.0 ; CS%D_v_Cor(:,:) = 0.0 + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + Mean_SL = G%Z_ref do j=js,je ; do I=is-1,ie - CS%D_u_Cor(I,j) = 0.5 * (max(Mean_SL+G%bathyT(i+1,j),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) + CS%D_u_Cor(I,j) = 0.5 * (max(Mean_SL+G%bathyT(i+1,j),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H enddo ; enddo do J=js-1,je ; do i=is,ie - CS%D_v_Cor(i,J) = 0.5 * (max(Mean_SL+G%bathyT(i,j+1),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) + CS%D_v_Cor(i,J) = 0.5 * (max(Mean_SL+G%bathyT(i,j+1),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H enddo ; enddo do J=js-1,je ; do I=is-1,ie if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then CS%q_D(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - (max(((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0) + & - G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0)) + & - (G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0) + & - G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_to_Z*GV%H_subroundoff) ) + (Z_to_H * max(((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0) + & + G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0)) + & + (G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0) + & + G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_subroundoff) ) else ! All four h points are masked out so q_D(I,J) will is meaningless CS%q_D(I,J) = 0. endif @@ -4767,15 +4806,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0) - call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=US%m_to_Z*US%T_to_s) + call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=GV%m_to_H*US%T_to_s) call pass_var(lin_drag_h, G%Domain) do j=js,je ; do I=is-1,ie - CS%lin_drag_u(I,j) = (GV%Z_to_H * wave_drag_scale) * & - 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) + CS%lin_drag_u(I,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) enddo ; enddo do J=js-1,je ; do i=is,ie - CS%lin_drag_v(i,J) = (GV%Z_to_H * wave_drag_scale) * & - 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) + CS%lin_drag_v(i,J) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) enddo ; enddo deallocate(lin_drag_h) endif @@ -4790,7 +4827,12 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! Estimate the maximum stable barotropic time step. gtot_estimate = 0.0 - do k=1,GV%ke ; gtot_estimate = gtot_estimate + GV%g_prime(K) ; enddo + if (GV%Boussinesq) then + do k=1,GV%ke ; gtot_estimate = gtot_estimate + GV%H_to_Z*GV%g_prime(K) ; enddo + else + H_to_Z = GV%H_to_RZ / CS%Rho_BT_lin + do k=1,GV%ke ; gtot_estimate = gtot_estimate + H_to_Z*GV%g_prime(K) ; enddo + endif call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra) if (dtbt_input > 0.0) then @@ -4957,16 +4999,17 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, if (.not.CS%nonlin_stress) then Mean_SL = G%Z_ref + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin do j=js,je ; do I=is-1,ie if (G%mask2dCu(I,j)>0.) then - CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL) + CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (Z_to_H * ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL)) else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless CS%IDatu(I,j) = 0. endif enddo ; enddo do J=js-1,je ; do i=is,ie if (G%mask2dCv(i,J)>0.) then - CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL) + CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (Z_to_H * ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL)) else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless CS%IDatv(i,J) = 0. endif From fffb6f350533f228019b1cbc8d3794edd91260ba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 31 May 2023 05:48:06 -0400 Subject: [PATCH 022/146] +*Use thickness_to_dz in tracer modules Use thickness_to_dz to convert layer thicknesses to depths in 4 tracer modules (DOME_tracer, dye_example, ideal_age_example and nw2_tracers) so that this conversion is done correctly in non-Boussineq mode, and there is no longer any dependency on the Boussinesq reference density in that mode. This change includes the addition of a thermo_var_ptrs argument to 5 routines (initialize_DOME_tracer, initialize_dye_tracer, dye_tracer_column_physics ideal_age_tracer_column_physics and count_BL_layers) and changes to the units of some internal variables, and the addition of 6 new 2-d or 3-d arrays with the vertical distance across layers. An unused param_file_type argument to initialize_DOME_tracer was also eliminated. Comments were also added to describe the units of 5 of the variables in the ideal age tracer control structure and 7 internal variables in that same module, and there was some minor cleanup of the formatting cf calls in tracer_flow_control_init. There was some minor refactoring in the ns2_tracers module to use SZK_(GV) instead of SZK_(G) to declare the vertical extent of some arrays, and the vertical indexing convention for interfaces in nw2_tracer_dist was revised from starting at 0 to start at 1 for consistency with all the other code in MOM6. Also moved the code to do halo updates for the physical model state variables and call calc_derived_thermo before calling tracer_flow_control_init, because some routines there are now using the layer average specific volume to convert between thicknesses and heights when in non-Boussinesq mode. All answers in Boussinesq mode are bitwise identical, but these passive tracer modules have slightly different answers in non-Boussinesq mode. There are changes to the non-optional arguments to 4 public interfaces. --- src/core/MOM.F90 | 40 ++++++++-------- src/tracer/DOME_tracer.F90 | 66 ++++++++++++++------------ src/tracer/MOM_tracer_flow_control.F90 | 27 +++++------ src/tracer/dye_example.F90 | 39 ++++++++------- src/tracer/ideal_age_example.F90 | 66 ++++++++++++++------------ src/tracer/nw2_tracers.F90 | 39 ++++++++------- 6 files changed, 149 insertions(+), 128 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d7e2d74735..d1d4be51dd 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3124,26 +3124,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call ALE_register_diags(Time, G, GV, US, diag, CS%ALE_CSp) endif - ! This subroutine initializes any tracer packages. - call tracer_flow_control_init(.not.new_sim, Time, G, GV, US, CS%h, param_file, & - CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & - CS%ALE_sponge_CSp, CS%tv) - if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp - - ! If running in offline tracer mode, initialize the necessary control structure and - ! parameters - if (present(offline_tracer_mode)) offline_tracer_mode=CS%offline_tracer_mode - - if (CS%offline_tracer_mode) then - ! Setup some initial parameterizations and also assign some of the subtypes - call offline_transport_init(param_file, CS%offline_CSp, CS%diabatic_CSp, G, GV, US) - call insert_offline_main( CS=CS%offline_CSp, ALE_CSp=CS%ALE_CSp, diabatic_CSp=CS%diabatic_CSp, & - diag=CS%diag, OBC=CS%OBC, tracer_adv_CSp=CS%tracer_adv_CSp, & - tracer_flow_CSp=CS%tracer_flow_CSp, tracer_Reg=CS%tracer_Reg, & - tv=CS%tv, x_before_y=(MODULO(first_direction,2)==0), debug=CS%debug ) - call register_diags_offline_transport(Time, CS%diag, CS%offline_CSp, GV, US) - endif - !--- set up group pass for u,v,T,S and h. pass_uv_T_S_h also is used in step_MOM call cpu_clock_begin(id_clock_pass_init) dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) @@ -3169,6 +3149,26 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call cpu_clock_end(id_clock_pass_init) + ! This subroutine initializes any tracer packages. + call tracer_flow_control_init(.not.new_sim, Time, G, GV, US, CS%h, param_file, & + CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & + CS%ALE_sponge_CSp, CS%tv) + if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp + + ! If running in offline tracer mode, initialize the necessary control structure and + ! parameters + if (present(offline_tracer_mode)) offline_tracer_mode=CS%offline_tracer_mode + + if (CS%offline_tracer_mode) then + ! Setup some initial parameterizations and also assign some of the subtypes + call offline_transport_init(param_file, CS%offline_CSp, CS%diabatic_CSp, G, GV, US) + call insert_offline_main( CS=CS%offline_CSp, ALE_CSp=CS%ALE_CSp, diabatic_CSp=CS%diabatic_CSp, & + diag=CS%diag, OBC=CS%OBC, tracer_adv_CSp=CS%tracer_adv_CSp, & + tracer_flow_CSp=CS%tracer_flow_CSp, tracer_Reg=CS%tracer_Reg, & + tv=CS%tv, x_before_y=(MODULO(first_direction,2)==0), debug=CS%debug ) + call register_diags_offline_transport(Time, CS%diag, CS%offline_CSp, GV, US) + endif + call register_obsolete_diagnostics(param_file, CS%diag) if (use_frazil) then diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 98788843e3..e0bd659a60 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -10,6 +10,7 @@ module DOME_tracer use MOM_forcing_type, only : forcing use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_tracer_type use MOM_open_boundary, only : OBC_segment_type @@ -19,7 +20,7 @@ module DOME_tracer use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -156,7 +157,7 @@ end function register_DOME_tracer !> Initializes the NTR tracer fields in tr(:,:,:,:) and sets up the tracer output. subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & - sponge_CSp, param_file) + sponge_CSp, tv) 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 @@ -170,27 +171,27 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & !! call to DOME_register_tracer. type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure !! for the sponges, if they are in use. - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables -! Local variables + ! Local variables real, allocatable :: temp(:,:,:) ! Target values for the tracers in the sponges, perhaps in [g kg-1] character(len=16) :: name ! A variable's name in a NetCDF file. real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: tr_y ! Initial zonally uniform tracer concentrations, perhaps in [g kg-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]. + real :: dz_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m or kg m-2]. real :: e(SZK_(GV)+1) ! Interface heights relative to the sea surface (negative down) [Z ~> m] real :: e_top ! Height of the top of the tracer band relative to the sea surface [Z ~> m] real :: e_bot ! Height of the bottom of the tracer band relative to the sea surface [Z ~> m] real :: d_tr ! A change in tracer concentrations, in tracer units, perhaps [g kg-1] integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m - integer :: IsdB, IedB, JsdB, JedB if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - h_neglect = GV%H_subroundoff + + dz_neglect = GV%dz_subroundoff CS%Time => day CS%diag => diag @@ -225,31 +226,34 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & enddo ; enddo ; enddo if (NTR >= 7) then - do j=js,je ; do i=is,ie - e(1) = 0.0 - do k=1,nz - e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z - do m=7,NTR - e_top = -CS%sheet_spacing * (real(m-6)) - e_bot = -CS%sheet_spacing * (real(m-6) + 0.5) - if (e_top < e(K)) then - if (e_top < e(K+1)) then ; d_tr = 0.0 - elseif (e_bot < e(K+1)) then - d_tr = 1.0 * (e_top-e(K+1)) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) - else ; d_tr = 1.0 * (e_top-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) + do j=js,je + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie + e(1) = 0.0 + do k=1,nz + e(K+1) = e(K) - dz(i,k) + do m=7,NTR + e_top = -CS%sheet_spacing * (real(m-6)) + e_bot = -CS%sheet_spacing * (real(m-6) + 0.5) + if (e_top < e(K)) then + if (e_top < e(K+1)) then ; d_tr = 0.0 + elseif (e_bot < e(K+1)) then + d_tr = 1.0 * (e_top-e(K+1)) / (dz(i,k)+dz_neglect) + else ; d_tr = 1.0 * (e_top-e_bot) / (dz(i,k)+dz_neglect) + endif + elseif (e_bot < e(K)) then + if (e_bot < e(K+1)) then ; d_tr = 1.0 + else ; d_tr = 1.0 * (e(K)-e_bot) / (dz(i,k)+dz_neglect) + endif + else + d_tr = 0.0 endif - elseif (e_bot < e(K)) then - if (e_bot < e(K+1)) then ; d_tr = 1.0 - else ; d_tr = 1.0 * (e(K)-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) - endif - else - d_tr = 0.0 - endif - if (h(i,j,k) < 2.0*GV%Angstrom_H) d_tr=0.0 - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + d_tr + if (dz(i,k) < 2.0*GV%Angstrom_Z) d_tr=0.0 + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + d_tr + enddo enddo enddo - enddo ; enddo + enddo endif endif diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index fc50fc4d1b..bf4988488b 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -317,34 +317,31 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag sponge_CSp) if (CS%use_DOME_tracer) & call initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS%DOME_tracer_CSp, & - sponge_CSp, param_file) + sponge_CSp, tv) if (CS%use_ISOMIP_tracer) & call initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS%ISOMIP_tracer_CSp, & ALE_sponge_CSp) if (CS%use_RGC_tracer) & - call initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, & - CS%RGC_tracer_CSp, sponge_CSp, ALE_sponge_CSp) + call initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS%RGC_tracer_CSp, & + sponge_CSp, ALE_sponge_CSp) if (CS%use_ideal_age) & call initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS%ideal_age_tracer_CSp, & - sponge_CSp) + sponge_CSp) if (CS%use_regional_dyes) & - call initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS%dye_tracer_CSp, & - sponge_CSp) + call initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS%dye_tracer_CSp, sponge_CSp, tv) if (CS%use_oil) & - call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, & - sponge_CSp) + call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, sponge_CSp) if (CS%use_advection_test_tracer) & call initialize_advection_test_tracer(restart, day, G, GV, h, diag, OBC, CS%advection_test_tracer_CSp, & sponge_CSp) if (CS%use_OCMIP2_CFC) & - call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, & - sponge_CSp) + call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, sponge_CSp) if (CS%use_CFC_cap) & call initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS%CFC_cap_CSp) if (CS%use_MOM_generic_tracer) & call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, & - CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) + 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, US, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & sponge_CSp, tv) @@ -488,13 +485,13 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, minimum_forcing_depth=minimum_forcing_depth) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%ideal_age_tracer_CSp, & + G, GV, US, tv, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth, & Hbl=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%dye_tracer_CSp, & + G, GV, US, tv, CS%dye_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_oil) & @@ -567,10 +564,10 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%RGC_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%ideal_age_tracer_CSp, Hbl=Hml) + G, GV, US, tv, CS%ideal_age_tracer_CSp, Hbl=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%dye_tracer_CSp) + G, GV, US, tv, CS%dye_tracer_CSp) if (CS%use_oil) & call oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%oil_tracer_CSp, tv) diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index fbc2b28a95..ff2199fc80 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -11,6 +11,7 @@ module regional_dyes use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS @@ -21,7 +22,7 @@ module regional_dyes use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -189,7 +190,7 @@ end function register_dye_tracer !> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. -subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_CSp) +subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_CSp, tv) logical, intent(in) :: restart !< .true. if the fields have already been !! read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -202,10 +203,12 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C !! conditions are used. type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. - type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure - !! for the sponges, if they are in use. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure + !! for the sponges, if they are in use. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables -! Local variables + ! Local variables + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] integer :: i, j, k, m @@ -216,8 +219,9 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C CS%diag => diag ! Establish location of source - do m= 1, CS%ntr - do j=G%jsd,G%jed ; do i=G%isd,G%ied + do j=G%jsc,G%jec + call thickness_to_dz(h, tv, dz, j, G, GV) + do m=1,CS%ntr ; do i=G%isc,G%iec ! A dye is set dependent on the center of the cell being inside the rectangular box. if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & @@ -226,8 +230,8 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C G%mask2dT(i,j) > 0.0 ) then z_bot = 0.0 do k = 1, GV%ke - z_bot = z_bot - h(i,j,k)*GV%H_to_Z - z_center = z_bot + 0.5*h(i,j,k)*GV%H_to_Z + z_bot = z_bot - dz(i,k) + z_center = z_bot + 0.5*dz(i,k) if ( z_center > -CS%dye_source_maxdepth(m) .and. & z_center < -CS%dye_source_mindepth(m) ) then CS%tr(i,j,k,m) = 1.0 @@ -244,7 +248,7 @@ end subroutine initialize_dye_tracer !! This is a simple example of a set of advected passive tracers. !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & +subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, tv, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -264,6 +268,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US !! and tracer forcing fields. Unused fields have NULL ptrs. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -271,8 +276,9 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [H ~> m or kg m-2] -! Local variables + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] integer :: i, j, k, is, ie, js, je, nz, m @@ -284,7 +290,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do m=1,CS%ntr - do k=1,nz ;do j=js,je ; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & @@ -297,8 +303,9 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US enddo endif - do m=1,CS%ntr - do j=G%jsd,G%jed ; do i=G%isd,G%ied + do j=js,je + call thickness_to_dz(h_new, tv, dz, j, G, GV) + do m=1,CS%ntr ; do i=is,ie ! A dye is set dependent on the center of the cell being inside the rectangular box. if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & @@ -307,8 +314,8 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US G%mask2dT(i,j) > 0.0 ) then z_bot = 0.0 do k=1,nz - z_bot = z_bot - h_new(i,j,k)*GV%H_to_Z - z_center = z_bot + 0.5*h_new(i,j,k)*GV%H_to_Z + z_bot = z_bot - dz(i,k) + z_center = z_bot + 0.5*dz(i,k) if ( z_center > -CS%dye_source_maxdepth(m) .and. & z_center < -CS%dye_source_mindepth(m) ) then CS%tr(i,j,k,m) = 1.0 diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index dfa5e894db..8492437cb6 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -12,6 +12,7 @@ module ideal_age_example use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_interface_heights, only : thickness_to_dz use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS use MOM_spatial_means, only : global_mass_int_EFP @@ -21,7 +22,7 @@ module ideal_age_example use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -46,13 +47,13 @@ module ideal_age_example logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? - real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. - real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface. - real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. - real, dimension(NTR_MAX) :: growth_rate !< The exponential growth rate for the young value [year-1]. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package [years] or other units + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value [years] or other units + real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface [years] or other units + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out [years] or other units + real, dimension(NTR_MAX) :: growth_rate !< The exponential growth rate for the young value [year-1] real, dimension(NTR_MAX) :: tracer_start_year !< The year in which tracers start aging, or at which the - !! surface value equals young_val, in years. + !! surface value equals young_val [years]. logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of !! layers above the BL depth instead of the fixed nkbl value. integer :: BL_residence_num !< The tracer number assigned to the BL residence tracer in this module @@ -296,7 +297,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers -subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & +subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, tv, CS, & evap_CFL_limit, minimum_forcing_depth, Hbl) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -316,6 +317,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! and tracer forcing fields. Unused fields have NULL ptrs. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -331,12 +333,12 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: BL_layers ! Stores number of layers in boundary layer - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified - real :: young_val ! The "young" value for the tracers. + real, dimension(SZI_(G),SZJ_(G)) :: BL_layers ! Stores number of layers in boundary layer [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real :: young_val ! The "young" value for the tracers [years] or other units real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] - real :: year ! The time in years. - real :: layer_frac + real :: year ! The time in years [years] + real :: layer_frac ! The fraction of the current layer that is within the mixed layer [nondim] integer :: i, j, k, is, ie, js, je, nz, m, nk character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -347,7 +349,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, endif if (CS%use_real_BL_depth .and. present(Hbl)) then - call count_BL_layers(G, GV, h_old, Hbl, BL_layers) + call count_BL_layers(G, GV, h_old, Hbl, tv, BL_layers) endif if (.not.associated(CS)) return @@ -576,33 +578,37 @@ subroutine ideal_age_example_end(CS) endif end subroutine ideal_age_example_end -subroutine count_BL_layers(G, GV, h, Hbl, BL_layers) +subroutine count_BL_layers(G, GV, h, Hbl, tv, BL_layers) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hbl !< Boundary layer depth [Z ~> m] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BL_layers !< Number of model layers in the boundary layer + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BL_layers !< Number of model layers in the boundary layer [nondim] - real :: current_depth + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: current_depth ! Distance from the free surface [Z ~> m] integer :: i, j, k, is, ie, js, je, nz, m, nk character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke BL_layers(:,:) = 0. - do j=js,je ; do i=is,ie - - current_depth = 0. - do k=1,nz - current_depth = current_depth + h(i,j,k)*GV%H_to_Z - if (Hbl(i,j) <= current_depth) then - BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / (h(i,j,k)*GV%H_to_Z)) - exit - else - BL_layers(i,j) = BL_layers(i,j) + 1.0 - endif + do j=js,je + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie + current_depth = 0. + do k=1,nz + current_depth = current_depth + dz(i,k) + if (Hbl(i,j) <= current_depth) then + BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / dz(i,k)) + exit + else + BL_layers(i,j) = BL_layers(i,j) + 1.0 + endif + enddo enddo - enddo ; enddo + enddo end subroutine count_BL_layers diff --git a/src/tracer/nw2_tracers.F90 b/src/tracer/nw2_tracers.F90 index e9d0bd5ef7..3c8fbe4ae8 100644 --- a/src/tracer/nw2_tracers.F90 +++ b/src/tracer/nw2_tracers.F90 @@ -9,6 +9,7 @@ module nw2_tracers use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS use MOM_time_manager, only : time_type, time_type_to_real @@ -115,7 +116,7 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables @@ -124,7 +125,8 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous !! call to register_nw2_tracer. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Vertical extent of layers [Z ~> m] real :: rscl ! z* scaling factor [nondim] character(len=8) :: var_name ! The variable's name. integer :: i, j, k, m @@ -135,20 +137,22 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) CS%diag => diag ! Calculate z* interface positions + call thickness_to_dz(h, tv, dz, G, GV, US) + if (GV%Boussinesq) then ! First calculate interface positions in z-space (m) do j=G%jsc,G%jec ; do i=G%isc,G%iec eta(i,j,GV%ke+1) = - G%mask2dT(i,j) * G%bathyT(i,j) enddo ; enddo do k=GV%ke,1,-1 ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h(i,j,k) * GV%H_to_Z + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) enddo ; enddo ; enddo ! Re-calculate for interface positions in z*-space (m) do j=G%jsc,G%jec ; do i=G%isc,G%iec if (G%bathyT(i,j)>0.) then rscl = G%bathyT(i,j) / ( eta(i,j,1) + G%bathyT(i,j) ) do K=GV%ke, 1, -1 - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h(i,j,k) * GV%H_to_Z * rscl + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) * rscl enddo endif enddo ; enddo @@ -176,15 +180,15 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: ea !< an array to which the amount of fluid entrained !! from the layer above during this call will be !! added [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: eb !< an array to which the amount of fluid entrained !! from the layer below during this call will be !! added [H ~> m or kg m-2]. @@ -206,8 +210,9 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Vertical extent of layers [Z ~> m] integer :: i, j, k, m real :: dt_x_rate ! dt * restoring rate [nondim] real :: rscl ! z* scaling factor [nondim] @@ -231,20 +236,22 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US endif ! Calculate z* interface positions + call thickness_to_dz(h_new, tv, dz, G, GV, US) + if (GV%Boussinesq) then - ! First calculate interface positions in z-space (m) + ! First calculate interface positions in z-space [Z ~> m] do j=G%jsc,G%jec ; do i=G%isc,G%iec eta(i,j,GV%ke+1) = - G%mask2dT(i,j) * G%bathyT(i,j) enddo ; enddo do k=GV%ke,1,-1 ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h_new(i,j,k) * GV%H_to_Z + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) enddo ; enddo ; enddo - ! Re-calculate for interface positions in z*-space (m) + ! Re-calculate for interface positions in z*-space [Z ~> m] do j=G%jsc,G%jec ; do i=G%isc,G%iec if (G%bathyT(i,j)>0.) then rscl = G%bathyT(i,j) / ( eta(i,j,1) + G%bathyT(i,j) ) do K=GV%ke, 1, -1 - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h_new(i,j,k) * GV%H_to_Z * rscl + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) * rscl enddo endif enddo ; enddo @@ -269,7 +276,7 @@ real function nw2_tracer_dist(m, G, GV, eta, i, j, k) integer, intent(in) :: m !< Indicates the NW2 tracer type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),0:SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: eta !< Interface position [Z ~> m] integer, intent(in) :: i !< Cell index i integer, intent(in) :: j !< Cell index j @@ -280,7 +287,7 @@ real function nw2_tracer_dist(m, G, GV, eta, i, j, k) pi = 2.*acos(0.) x = ( G%geolonT(i,j) - G%west_lon ) / G%len_lon ! 0 ... 1 y = -G%geolatT(i,j) / G%south_lat ! -1 ... 1 - z = - 0.5 * ( eta(i,j,K-1) + eta(i,j,K) ) / GV%max_depth ! 0 ... 1 + z = - 0.5 * ( eta(i,j,K) + eta(i,j,K+1) ) / GV%max_depth ! 0 ... 1 select case ( mod(m-1,3) ) case (0) ! sin(2 pi x/L) nw2_tracer_dist = sin( 2.0 * pi * x ) From 55fc59a36f278f5658a8927208f3fed35879aaa6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 Jul 2023 12:52:28 -0400 Subject: [PATCH 023/146] Fix a bug in the OMP directive for plume_flux Changed a recently added OMP directive for plume_flux from private to firstprivate to reflect how this variable is actually used. This bug was introduced with PR #401, but was causing sporadic failures in some of our pipeline tests with the intel compiler (essentially due to initialized memory when openMP is used) for subsequent commits. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 3742e93229..009cdc4075 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1207,8 +1207,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP drhodt,drhods,pen_sw_bnd_rate, & !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & !$OMP mixing_depth,A_brine,fraction_left_brine, & - !$OMP plume_flux,plume_fraction,dK) & - !$OMP firstprivate(SurfPressure) + !$OMP plume_fraction,dK) & + !$OMP firstprivate(SurfPressure,plume_flux) do j=js,je ! Work in vertical slices for efficiency From 5af37b6545a70cc86c49c345a750074a2da1e364 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 27 Jun 2023 18:34:43 -0400 Subject: [PATCH 024/146] Generalized MOM restart function This patch merges the internal `save_restart` function with the new `save_MOM6_internal_state` function into a new general MOM restart function. It also makes an effort to eliminate `MOM_restart` as a driver dependency, narrowing the required MOM API for existing and future drivers. Also removes the `restart_CSp` argument from `MOM_wave_interface_init`, since it appeared to be used for nothing. --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 26 +++---- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 28 +++---- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 36 ++++----- config_src/drivers/solo_driver/MOM_driver.F90 | 25 +++---- src/core/MOM.F90 | 74 ++++++++++--------- src/user/MOM_wave_interface.F90 | 3 +- 6 files changed, 84 insertions(+), 108 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index bd86a633c6..5fde791724 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -14,7 +14,8 @@ module ocean_model_mod use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state +use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type @@ -37,7 +38,6 @@ module ocean_model_mod use MOM_grid, only : ocean_grid_type use MOM_io, only : write_version_number, stdout_if_root use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_surface_forcing_gfdl, only : surface_forcing_init, convert_IOB_to_fluxes use MOM_surface_forcing_gfdl, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum @@ -209,9 +209,6 @@ module ocean_model_mod Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -279,7 +276,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas ! initialization of ice shelf parameters and arrays. call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & diag_ptr=OS%diag, count_calls=.true., ice_shelf_CSp=OS%ice_shelf_CSp, & waves_CSp=OS%Waves) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & @@ -572,7 +569,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda endif if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then ! This is the first call to update_ocean_model. - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif Time_thermo_start = OS%Time @@ -693,24 +690,22 @@ subroutine ocean_model_restart(OS, timestamp) "restart files can only be created after the buoyancy forcing is applied.") if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif end subroutine ocean_model_restart @@ -758,16 +753,13 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) - end subroutine ocean_model_save_restart !> Initialize the public ocean type diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index cdf93b1bef..82d8881c03 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -14,7 +14,8 @@ module MOM_ocean_model_mct use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state +use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging @@ -34,7 +35,6 @@ module MOM_ocean_model_mct use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_surface_forcing_mct, only : surface_forcing_init, convert_IOB_to_fluxes use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum @@ -207,9 +207,6 @@ module MOM_ocean_model_mct Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -271,7 +268,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & diag_ptr=OS%diag, count_calls=.true., waves_CSp=OS%Waves) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & @@ -575,7 +572,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif call disable_averaging(OS%diag) @@ -689,35 +686,32 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV, filename=restartname) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) else if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif endif @@ -768,7 +762,7 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 205dbdadcc..9ee7ef921f 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -14,7 +14,8 @@ module MOM_ocean_model_nuopc use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state +use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging @@ -34,7 +35,6 @@ module MOM_ocean_model_nuopc use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_time_manager, only : time_type, get_time, set_time, operator(>) use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) @@ -214,9 +214,6 @@ module MOM_ocean_model_nuopc Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -281,7 +278,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & diag_ptr=OS%diag, count_calls=.true., waves_CSp=OS%Waves) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & @@ -407,7 +404,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because ! it also initializes statistical waves. - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag, OS%restart_CSp) + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) if (associated(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & @@ -608,7 +605,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif call disable_averaging(OS%diag) @@ -730,36 +727,32 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) endif - - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) else if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) + OS%dirs%restart_output_dir, time_stamped=.true.) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif endif if (present(stoch_restartname)) then @@ -814,16 +807,13 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - - call save_MOM6_internal_start(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) - end subroutine ocean_model_save_restart !> Initialize the public ocean type diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 72981122f2..84c2eec5b5 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -31,7 +31,8 @@ program MOM6 use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized - use MOM, only : step_offline, save_MOM6_internal_state + use MOM, only : step_offline + use MOM, only : save_MOM_restart use MOM_coms, only : Set_PElist use MOM_domains, only : MOM_infra_init, MOM_infra_end, set_MOM_thread_affinity use MOM_ensemble_manager, only : ensemble_manager_init, get_ensemble_size @@ -52,7 +53,6 @@ program MOM6 use MOM_io, only : file_exists, open_ASCII_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end use MOM_io, only : APPEND_FILE, READONLY_FILE - use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions,only : uppercase use MOM_surface_forcing, only : set_forcing, forcing_save_restart use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS @@ -177,9 +177,6 @@ program MOM6 logical :: override_shelf_fluxes !< If true, and shelf dynamics are active, !! the data_override feature is enabled (only for MOSAIC grid types) type(wave_parameters_cs), pointer :: waves_CSp => NULL() - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure !----------------------------------------------------------------------- @@ -281,7 +278,7 @@ program MOM6 if (segment_start_time_set) then ! In this case, the segment starts at a time fixed by ocean_solo.res Time = segment_start_time - call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & + call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, & segment_start_time, offline_tracer_mode=offline_tracer_mode, & diag_ptr=diag, tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp, & waves_CSp=Waves_CSp) @@ -289,7 +286,7 @@ program MOM6 ! In this case, the segment starts at a time read from the MOM restart file ! or is left at Start_time by MOM_initialize. Time = Start_time - call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & + call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, & offline_tracer_mode=offline_tracer_mode, diag_ptr=diag, & tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp, waves_CSp=Waves_CSp) endif @@ -473,7 +470,7 @@ program MOM6 endif if (ns==1) then - call finish_MOM_initialization(Time, dirs, MOM_CSp, restart_CSp) + call finish_MOM_initialization(Time, dirs, MOM_CSp) endif ! This call steps the model over a time dt_forcing. @@ -564,22 +561,19 @@ program MOM6 if ((permit_incr_restart) .and. (fluxes%fluxes_used) .and. & (Time + (Time_step_ocean/2) > restart_time)) then if (BTEST(Restart_control,1)) then - call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, .true., GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, & + time_stamped=.true., GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir, .true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir, .true.) - call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time, .true.) endif if (BTEST(Restart_control,0)) then - call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) - call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time) endif restart_time = restart_time + restint endif @@ -600,10 +594,9 @@ program MOM6 "For conservation, the ocean restart files can only be "//& "created after the buoyancy forcing is applied.") - call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, GV=GV) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) - call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time) ! Write the ocean solo restart file. call write_ocean_solo_res(Time, Start_time, calendar_type, & diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d1d4be51dd..5dd3f45634 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -435,13 +435,16 @@ module MOM type(porous_barrier_type) :: pbv !< porous barrier fractional cell metrics type(particles), pointer :: particles => NULL() ! NULL() !< a pointer to the stochastics control structure + type(MOM_restart_CS), pointer :: restart_CS => NULL() + !< Pointer to MOM's restart control structure end type MOM_control_struct public initialize_MOM, finish_MOM_initialization, MOM_end -public step_MOM, step_offline, save_MOM6_internal_state +public step_MOM, step_offline public extract_surface_state, get_ocean_stocks public get_MOM_state_elements, MOM_state_is_synchronized public allocate_surface_state, deallocate_surface_state +public save_MOM_restart !>@{ CPU time clock IDs integer :: id_clock_ocean @@ -1903,7 +1906,7 @@ end subroutine step_offline !> Initialize MOM, including memory allocation, setting up parameters and diagnostics, !! initializing the ocean state variables, and initializing subsidiary modules -subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & +subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp) type(time_type), target, intent(inout) :: Time !< model time, set in this routine @@ -1911,9 +1914,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse type(directories), intent(out) :: dirs !< structure with directory paths type(MOM_control_struct), intent(inout), target :: CS !< pointer set in this routine to MOM control structure - type(MOM_restart_CS), pointer :: restart_CSp !< pointer set in this routine to the - !! restart control structure that will - !! be used for MOM. type(time_type), optional, intent(in) :: Time_in !< time passed to MOM_initialize_state when !! model is not being started from a restart file logical, optional, intent(out) :: offline_tracer_mode !< True is returned if tracers are being run offline @@ -1939,6 +1939,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & type(dyn_horgrid_type), pointer :: dG_in => NULL() type(diag_ctrl), pointer :: diag => NULL() type(unit_scale_type), pointer :: US => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() character(len=4), parameter :: vers_num = 'v2.0' integer :: turns ! Number of grid quarter-turns @@ -1957,7 +1958,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & type(sponge_CS), pointer :: sponge_in_CSp => NULL() type(ALE_sponge_CS), pointer :: ALE_sponge_in_CSp => NULL() type(oda_incupd_CS),pointer :: oda_incupd_in_CSp => NULL() - ! This include declares and sets the variable "version". # include "version_variable.h" @@ -2665,7 +2665,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Set the fields that are needed for bitwise identical restarting ! the time stepping scheme. - call restart_init(param_file, restart_CSp) + call restart_init(param_file, CS%restart_CS) + restart_CSp => CS%restart_CS + call set_restart_fields(GV, US, param_file, CS, restart_CSp) if (CS%split) then call register_restarts_dyn_split_RK2(HI, GV, US, param_file, & @@ -3219,13 +3221,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & end subroutine initialize_MOM !> Finishes initializing MOM and writes out the initial conditions. -subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) +subroutine finish_MOM_initialization(Time, dirs, CS) type(time_type), intent(in) :: Time !< model time, used in this routine type(directories), intent(in) :: dirs !< structure with directory paths type(MOM_control_struct), intent(inout) :: CS !< MOM control structure - type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control - !! structure that will be used for MOM. - ! Local variables + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing ! metrics and related information type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure @@ -3247,7 +3247,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) ! Write initial conditions if (CS%write_IC) then allocate(restart_CSp_tmp) - restart_CSp_tmp = restart_CSp + restart_CSP_tmp = CS%restart_CS call restart_registry_lock(restart_CSp_tmp, unlocked=.true.) allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1)) call find_eta(CS%h, CS%tv, G, GV, US, z_interface, dZref=G%Z_ref) @@ -3926,27 +3926,35 @@ subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) end subroutine get_ocean_stocks -!> Trigger a writing of restarts for the MOM6 internal state -!! -!! Currently this applies to the state that does not take the form -!! of simple arrays for which the generic save_restart() function -!! can be used. -!! -!! Todo: -!! [ ] update particles to use Time and directories -!! [ ] move the call to generic save_restart() in here. -subroutine save_MOM6_internal_state(CS, dirs, time, stamp_time) - type(MOM_control_struct), intent(inout) :: CS !< MOM control structure - character(len=*), intent(in) :: dirs !< The directory where the restart - !! files are to be written - type(time_type), intent(in) :: time !< The current model time - logical, optional, intent(in) :: stamp_time !< If present and true, add time-stamp - - ! Could call save_restart(CS%restart_CSp) here - - if (CS%use_particles) call particles_save_restart(CS%particles, CS%h) - -end subroutine save_MOM6_internal_state +!> Save restart/pickup files required to initialize the MOM6 internal state. +subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & + GV, num_rest_files, write_IC) + type(MOM_control_struct), intent(inout) :: CS + !< MOM control structure + character(len=*), intent(in) :: directory + !< The directory where the restart files are to be written + type(time_type), intent(in) :: time + !< The current model time + type(ocean_grid_type), intent(inout) :: G + !< The ocean's grid structure + logical, optional, intent(in) :: time_stamped + !< If present and true, add time-stamp to the restart file names + character(len=*), optional, intent(in) :: filename + !< A filename that overrides the name in CS%restartfile + type(verticalGrid_type), optional, intent(in) :: GV + !< The ocean's vertical grid structure + integer, optional, intent(out) :: num_rest_files + !< number of restart files written + logical, optional, intent(in) :: write_IC + !< If present and true, initial conditions are being written + + call save_restart(directory, time, G, CS%restart_CS, & + time_stamped=time_stamped, filename=filename, GV=GV, & + num_rest_files=num_rest_files, write_IC=write_IC) + + ! TODO: Update particles to use Time and directories + if (CS%use_particles) call particles_save_restart(CS%particles, CS%h) +end subroutine save_MOM_restart !> End of ocean model, including memory deallocation diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a548436329..82ed753fb3 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -259,7 +259,7 @@ module MOM_wave_interface contains !> Initializes parameters related to MOM_wave_interface -subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restart_CSp) +subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) type(time_type), target, intent(in) :: Time !< Model time type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -267,7 +267,6 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar type(param_file_type), intent(in) :: param_file !< Input parameter structure type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic Pointer - type(MOM_restart_CS), optional, pointer:: restart_CSp!< Restart control structure ! Local variables character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. From 3d9190c99c4551b130a32f8b99e1fa6f1066c555 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 6 Jul 2023 10:32:17 -0400 Subject: [PATCH 025/146] Create restart directory if absent MOM simulations typically abort of the restart directory (usually RESTART) are absent. This patch adds POSIX support for mkdir() and creates the directory if it is missing. --- src/framework/MOM_get_input.F90 | 11 +++++++++++ src/framework/posix.F90 | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 43 insertions(+) diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index b6b5b89be9..09f7efc956 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -11,6 +11,7 @@ module MOM_get_input use MOM_file_parser, only : open_param_file, param_file_type use MOM_io, only : file_exists, close_file, slasher, ensembler use MOM_io, only : open_namelist_file, check_nml_error +use posix, only : mkdir implicit none ; private @@ -73,6 +74,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, endif ! Read namelist parameters + ! NOTE: Every rank is reading MOM_input_nml ierr=1 ; do while (ierr /= 0) read(unit, nml=MOM_input_nml, iostat=io, end=10) ierr = check_nml_error(io, 'MOM_input_nml') @@ -92,6 +94,15 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, dirs%restart_input_dir = slasher(ensembler(restart_input_dir)) dirs%input_filename = ensembler(input_filename) endif + + ! Create the RESTART directory if absent + if (is_root_PE()) then + if (.not. file_exists(dirs%restart_output_dir)) then + ierr = mkdir(trim(dirs%restart_output_dir), int(o'700')) + if (ierr == -1) & + call MOM_error(FATAL, 'Restart directory could not be created.') + endif + endif endif ! Open run-time parameter file(s) diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index 213ff4656d..9524543fb7 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -52,6 +52,21 @@ function chmod_posix(path, mode) result(rc) bind(c, name="chmod") !< Function return code end function chmod_posix + !> C interface to POSIX mkdir() + !! Users should use the Fortran-defined mkdir() function. + function mkdir_posix(path, mode) result(rc) bind(c, name="mkdir") + ! #include + ! int mkdir(const char *path, mode_t mode); + import :: c_char, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Zero-delimited file path + integer(kind=c_int), value, intent(in) :: mode + !< File permission to be assigned to file. + integer(kind=c_int) :: rc + !< Function return code + end function mkdir_posix + !> C interface to POSIX signal() !! Users should use the Fortran-defined signal() function. function signal_posix(sig, func) result(handle) bind(c, name="signal") @@ -240,6 +255,23 @@ function chmod(path, mode) result(rc) rc = int(rc_c) end function chmod +!> Create a file directory +!! +!! This creates a new directory named `path` with permissons set by `mode`. +!! If successful, it returns zero. Otherwise, it returns -1. +function mkdir(path, mode) result(rc) + character(len=*), intent(in) :: path + integer, intent(in) :: mode + integer :: rc + + integer(kind=c_int) :: mode_c + integer(kind=c_int) :: rc_c + + mode_c = int(mode, kind=c_int) + rc_c = mkdir_posix(path//c_null_char, mode_c) + rc = int(rc_c) +end function mkdir + !> Create a signal handler `handle` to be called when `sig` is detected. !! !! If successful, the previous handler for `sig` is returned. Otherwise, From 5efad9b983b494dc26f24cb1238d33cf6b0c5f1e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 21 Jul 2023 17:48:49 -0400 Subject: [PATCH 026/146] Use POSIX stat to check if restart dir exists Using inquire() to check for directory existence is not possible, since at least one compiler (Intel) does not consider directories to be files. The inquire call is replaced with a C interface to the POSIX stat() function. We do not fully emulate the behavior of stat, but we use its return value to determine existence of directories. This provides a more reliable method for identifying the existence of the directory. This should resolve many of the observed problems with RESTART creation in coupled runs. --- src/framework/MOM_get_input.F90 | 6 ++-- src/framework/posix.F90 | 49 ++++++++++++++++++++++++++++++++- src/framework/posix.h | 6 ++++ 3 files changed, 58 insertions(+), 3 deletions(-) diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index 09f7efc956..b6773ccb21 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -11,7 +11,7 @@ module MOM_get_input use MOM_file_parser, only : open_param_file, param_file_type use MOM_io, only : file_exists, close_file, slasher, ensembler use MOM_io, only : open_namelist_file, check_nml_error -use posix, only : mkdir +use posix, only : mkdir, stat, stat_buf implicit none ; private @@ -55,6 +55,8 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, character(len=240) :: output_dir integer :: unit, io, ierr, valid_param_files + type(stat_buf) :: buf + namelist /MOM_input_nml/ output_directory, input_filename, parameter_filename, & restart_input_dir, restart_output_dir @@ -97,7 +99,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, ! Create the RESTART directory if absent if (is_root_PE()) then - if (.not. file_exists(dirs%restart_output_dir)) then + if (stat(trim(dirs%restart_output_dir), buf) == -1) then ierr = mkdir(trim(dirs%restart_output_dir), int(o'700')) if (ierr == -1) & call MOM_error(FATAL, 'Restart directory could not be created.') diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index 9524543fb7..fffb619cba 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -13,6 +13,16 @@ module posix implicit none +!> Container for file metadata from stat +!! +!! NOTE: This is currently just a placeholder containing fields, such as size, +!! uid, mode, etc. A readable Fortran type may be used in the future. +type, bind(c) :: stat_buf + private + character(kind=c_char) :: state(SIZEOF_STAT_BUF) + !< Byte array containing file metadata +end type stat_buf + !> Container for the jump point buffer created by setjmp(). !! !! The buffer typically contains the current register values, stack pointers, @@ -67,6 +77,19 @@ function mkdir_posix(path, mode) result(rc) bind(c, name="mkdir") !< Function return code end function mkdir_posix + !> C interface to POSIX stat() + !! Users should use the Fortran-defined stat() function. + function stat_posix(path, buf) result(rc) bind(c, name="stat") + import :: c_char, stat_buf, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Pathname of a POSIX file + type(stat_buf), intent(in) :: buf + !< Information describing the file if it exists + integer(kind=c_int) :: rc + !< Function return code + end function + !> C interface to POSIX signal() !! Users should use the Fortran-defined signal() function. function signal_posix(sig, func) result(handle) bind(c, name="signal") @@ -272,6 +295,27 @@ function mkdir(path, mode) result(rc) rc = int(rc_c) end function mkdir +!> Get file status +!! +!! This obtains information about the named file and writes it to buf. +!! If found, it returns zero. Otherwise, it returns -1. +function stat(path, buf) result(rc) + character(len=*), intent(in) :: path + !< Pathname of file to be inspected + type(stat_buf), intent(out) :: buf + !< Buffer containing information about the file if it exists + ! NOTE: Currently the contents of buf are not readable, but we could move + ! the contents into a readable Fortran type. + integer :: rc + !< Function return code + + integer(kind=c_int) :: rc_c + + rc_c = stat_posix(path//c_null_char, buf) + + rc = int(rc_c) +end function stat + !> Create a signal handler `handle` to be called when `sig` is detected. !! !! If successful, the previous handler for `sig` is returned. Otherwise, @@ -391,6 +435,9 @@ function setjmp_missing(env) result(rc) bind(c) print '(a)', 'ERROR: setjmp() is not implemented in this build.' print '(a)', 'Recompile with autoconf or -DSETJMP_NAME=\"\".' error stop + + ! NOTE: compilers may expect a return value, even if it is unreachable + rc = -1 end function setjmp_missing !> Placeholder function for a missing or unconfigured longjmp @@ -418,7 +465,7 @@ function sigsetjmp_missing(env, savesigs) result(rc) bind(c) print '(a)', 'Recompile with autoconf or -DSIGSETJMP_NAME=\"\".' error stop - ! NOTE: Compilers may expect a return value, even if it is unreachable + ! NOTE: compilers may expect a return value, even if it is unreachable rc = -1 end function sigsetjmp_missing diff --git a/src/framework/posix.h b/src/framework/posix.h index f7cea0fec9..c4b09e1285 100644 --- a/src/framework/posix.h +++ b/src/framework/posix.h @@ -1,6 +1,12 @@ #ifndef MOM6_POSIX_H_ #define MOM6_POSIX_H_ +! STAT_BUF_SIZE should be set to sizeof(stat). +! The default value is based on glibc 2.28. +#ifndef SIZEOF_STAT_BUF +#define SIZEOF_STAT_BUF 144 +#endif + ! JMP_BUF_SIZE should be set to sizeof(jmp_buf). ! If unset, then use a typical glibc value (25 long ints) #ifndef SIZEOF_JMP_BUF From 84056b18f74b04b65c1c2b2ad65bc7e31258ff3a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 30 Mar 2023 13:10:19 -0400 Subject: [PATCH 027/146] *Cancel out Z_to_H factors in MOM_hor_visc.F90 Cancelled out factors of GV%Z_to_H in MOM_hor_visc.F90 to simplify the code and reduce the dependence on the value of GV%Rho_0 in non-Boussinesq mode. This involved changing the units of 3 internal variables in horizontal_viscosity and one element in the hor_visc_CS type to use thickness units or their inverse. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 9037c71c5a..83809d39db 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -98,7 +98,7 @@ module MOM_hor_visc !! the answers from the end of 2018, while higher values use updated !! and more robust forms of the same expressions. real :: GME_h0 !< The strength of GME tapers quadratically to zero when the bathymetric - !! depth is shallower than GME_H0 [Z ~> m] + !! total water column thickness is less than GME_H0 [H ~> m or kg m-2] real :: GME_efficiency !< The nondimensional prefactor multiplying the GME coefficient [nondim] real :: GME_limiter !< The absolute maximum value the GME coefficient is allowed to take [L2 T-1 ~> m2 s-1]. real :: min_grid_Kh !< Minimum horizontal Laplacian viscosity used to @@ -284,7 +284,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] - htot ! The total thickness of all layers [Z ~> m] + htot ! The total thickness of all layers [H ~> m or kg m-2] real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] @@ -353,8 +353,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: hu, hv ! Thicknesses interpolated by arithmetic means to corner ! points; these are first interpolated to u or v velocity ! points where masks are applied [H ~> m or kg m-2]. - real :: h_arith_q ! The arithmetic mean total thickness at q points [Z ~> m] - real :: I_GME_h0 ! The inverse of GME tapering scale [Z-1 ~> m-1] + real :: h_arith_q ! The arithmetic mean total thickness at q points [H ~> m or kg m-2] + real :: I_GME_h0 ! The inverse of GME tapering scale [H-1 ~> m-1 or m2 kg-1] real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] real :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m] @@ -494,7 +494,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, htot(i,j) = 0.0 enddo ; enddo do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 - htot(i,j) = htot(i,j) + GV%H_to_Z*h(i,j,k) + htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo I_GME_h0 = 1.0 / CS%GME_h0 @@ -2042,7 +2042,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & "The strength of GME tapers quadratically to zero when the bathymetric "//& "depth is shallower than GME_H0.", & - units="m", scale=US%m_to_Z, default=1000.0) + units="m", scale=GV%m_to_H, default=1000.0) call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & "The nondimensional prefactor multiplying the GME coefficient.", & units="nondim", default=1.0) From 3fd219112db9c8e108d878f6b6a4b0fda9d5ea5d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 14 Jul 2023 06:45:13 -0400 Subject: [PATCH 028/146] +*Revise the units of 12 vertvisc_type elements Revised the units of 12 vertvisc_type elements to be based on thicknesses, so that vertical viscosities (in [H Z T-1 ~> m2 s-1 or Pa s]) are stored as dynamic viscosites when in non-Boussinesq mode, with analogous changes to the diapycanl diffusivity (now in [H Z T-1 ~> m2 s-1 or kg m-1 s-1]). Similarly changed the units of the 2 Rayleigh drag velocity elements (Ray_u and Ray_v) of the vertvisc_type from vertical velocity units to thickness flux units and to more accurately reflect the nature of these fields. The bottom boundary layer TKE source element (TKE_BBL) was also revised to [H Z2 T-3 ~> m3 s-3 or W m-2]. This commit also adds required changes to the units of the viscosities or shear-driven diffusivities returned from KPP_calculate, calculate_CVMix_shear, calculate_CVMix_conv, Calculate_kappa_shear, Calc_kappa_shear_vertex, calculate_tidal_mixing and calculate_CVMix_tidal. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode unless GV%Rho_0 is chosen to be an integer power of 2. --- src/core/MOM_variables.F90 | 28 ++++---- src/parameterizations/lateral/MOM_MEKE.F90 | 4 +- .../vertical/MOM_CVMix_KPP.F90 | 12 ++-- .../vertical/MOM_CVMix_conv.F90 | 6 +- .../vertical/MOM_CVMix_shear.F90 | 16 ++--- .../vertical/MOM_diabatic_driver.F90 | 14 ++-- .../vertical/MOM_kappa_shear.F90 | 25 +++---- .../vertical/MOM_set_diffusivity.F90 | 48 +++++++------- .../vertical/MOM_set_viscosity.F90 | 66 +++++++++---------- .../vertical/MOM_tidal_mixing.F90 | 8 +-- .../vertical/MOM_vert_friction.F90 | 34 +++++----- 11 files changed, 131 insertions(+), 130 deletions(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 0c4a42e8c6..199524fa33 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -234,12 +234,12 @@ module MOM_variables real, allocatable, dimension(:,:) :: & bbl_thick_u, & !< The bottom boundary layer thickness at the u-points [Z ~> m]. bbl_thick_v, & !< The bottom boundary layer thickness at the v-points [Z ~> m]. - kv_bbl_u, & !< The bottom boundary layer viscosity at the u-points [Z2 T-1 ~> m2 s-1]. - kv_bbl_v, & !< The bottom boundary layer viscosity at the v-points [Z2 T-1 ~> m2 s-1]. - ustar_BBL, & !< The turbulence velocity in the bottom boundary layer at h points [Z T-1 ~> m s-1]. + kv_bbl_u, & !< The bottom boundary layer viscosity at the u-points [H Z T-1 ~> m2 s-1 or Pa s] + kv_bbl_v, & !< The bottom boundary layer viscosity at the v-points [H Z T-1 ~> m2 s-1 or Pa s] + ustar_BBL, & !< The turbulence velocity in the bottom boundary layer at + !! h points [H T-1 ~> m s-1 or kg m-2 s-1]. TKE_BBL, & !< A term related to the bottom boundary layer source of turbulent kinetic - !! energy, currently in [Z3 T-3 ~> m3 s-3], but may at some time be changed - !! to [R Z3 T-3 ~> W m-2]. + !! energy, currently in [H Z2 T-3 ~> m3 s-3 or W m-2]. taux_shelf, & !< The zonal stresses on the ocean under shelves [R Z L T-2 ~> Pa]. tauy_shelf !< The meridional stresses on the ocean under shelves [R Z L T-2 ~> Pa]. real, allocatable, dimension(:,:) :: tbl_thick_shelf_u @@ -247,9 +247,11 @@ module MOM_variables real, allocatable, dimension(:,:) :: tbl_thick_shelf_v !< Thickness of the viscous top boundary layer under ice shelves at v-points [Z ~> m]. real, allocatable, dimension(:,:) :: kv_tbl_shelf_u - !< Viscosity in the viscous top boundary layer under ice shelves at u-points [Z2 T-1 ~> m2 s-1]. + !< Viscosity in the viscous top boundary layer under ice shelves at + !! u-points [H Z T-1 ~> m2 s-1 or Pa s] real, allocatable, dimension(:,:) :: kv_tbl_shelf_v - !< Viscosity in the viscous top boundary layer under ice shelves at v-points [Z2 T-1 ~> m2 s-1]. + !< Viscosity in the viscous top boundary layer under ice shelves at + !! v-points [H Z T-1 ~> m2 s-1 or Pa s] real, allocatable, dimension(:,:) :: nkml_visc_u !< The number of layers in the viscous surface mixed layer at u-points [nondim]. !! This is not an integer because there may be fractional layers, and it is stored in @@ -258,24 +260,24 @@ module MOM_variables real, allocatable, dimension(:,:) :: nkml_visc_v !< The number of layers in the viscous surface mixed layer at v-points [nondim]. real, allocatable, dimension(:,:,:) :: & - Ray_u, & !< The Rayleigh drag velocity to be applied to each layer at u-points [Z T-1 ~> m s-1]. - Ray_v !< The Rayleigh drag velocity to be applied to each layer at v-points [Z T-1 ~> m s-1]. + Ray_u, & !< The Rayleigh drag velocity to be applied to each layer at u-points [H T-1 ~> m s-1 or Pa s m-1]. + Ray_v !< The Rayleigh drag velocity to be applied to each layer at v-points [H T-1 ~> m s-1 or Pa s m-1]. ! The following elements are pointers so they can be used as targets for pointers in the restart registry. real, pointer, dimension(:,:) :: MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. real, pointer, dimension(:,:) :: sfc_buoy_flx !< Surface buoyancy flux (derived) [Z2 T-3 ~> m2 s-3]. real, pointer, dimension(:,:,:) :: Kd_shear => NULL() !< The shear-driven turbulent diapycnal diffusivity at the interfaces between layers - !! in tracer columns [Z2 T-1 ~> m2 s-1]. + !! in tracer columns [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, pointer, dimension(:,:,:) :: Kv_shear => NULL() !< The shear-driven turbulent vertical viscosity at the interfaces between layers - !! in tracer columns [Z2 T-1 ~> m2 s-1]. + !! in tracer columns [H Z T-1 ~> m2 s-1 or Pa s] real, pointer, dimension(:,:,:) :: Kv_shear_Bu => NULL() !< The shear-driven turbulent vertical viscosity at the interfaces between layers in - !! corner columns [Z2 T-1 ~> m2 s-1]. + !! corner columns [H Z T-1 ~> m2 s-1 or Pa s] real, pointer, dimension(:,:,:) :: Kv_slow => NULL() !< The turbulent vertical viscosity component due to "slow" processes (e.g., tidal, - !! background, convection etc) [Z2 T-1 ~> m2 s-1]. + !! background, convection etc) [H Z T-1 ~> m2 s-1 or Pa s] real, pointer, dimension(:,:,:) :: TKE_turb => NULL() !< The turbulent kinetic energy per unit mass at the interfaces [Z2 T-2 ~> m2 s-2]. !! This may be at the tracer or corner points diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 0ef261a956..3059ca1637 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -311,13 +311,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h do j=js,je ; do I=is-1,ie drag_vel_u(I,j) = 0.0 if ((G%mask2dCu(I,j) > 0.0) .and. (visc%bbl_thick_u(I,j) > 0.0)) & - drag_vel_u(I,j) = visc%Kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) + drag_vel_u(I,j) = GV%H_to_Z*visc%Kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie drag_vel_v(i,J) = 0.0 if ((G%mask2dCv(i,J) > 0.0) .and. (visc%bbl_thick_v(i,J) > 0.0)) & - drag_vel_v(i,J) = visc%Kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) + drag_vel_v(i,J) = GV%H_to_Z*visc%Kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) enddo ; enddo !$OMP parallel do default(shared) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 32946021be..f5d30029f1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -616,7 +616,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & !! [Z2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP !! (out) Vertical viscosity including KPP - !! [Z2 T-1 ~> m2 s-1] + !! [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [nondim] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local trans. [nondim] type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence @@ -713,7 +713,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & else Kdiffusivity(:,1) = US%Z2_T_to_m2_s * Kt(i,j,:) Kdiffusivity(:,2) = US%Z2_T_to_m2_s * Ks(i,j,:) - Kviscosity(:) = US%Z2_T_to_m2_s * Kv(i,j,:) + Kviscosity(:) = GV%HZ_T_to_m2_s * Kv(i,j,:) endif IF (CS%LT_K_ENHANCEMENT) then @@ -862,15 +862,15 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & do k=1, GV%ke+1 Kt(i,j,k) = Kt(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,1) Ks(i,j,k) = Ks(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,2) - Kv(i,j,k) = Kv(i,j,k) + US%m2_s_to_Z2_T * Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) + Kv(i,j,k) = Kv(i,j,k) + GV%m2_s_to_HZ_T * Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) enddo else ! KPP replaces prior diffusivity when former is non-zero do k=1, GV%ke+1 if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,1) if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,2) - if (Kviscosity(k) /= 0.) Kv(i,j,k) = US%m2_s_to_Z2_T * Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) + if (Kviscosity(k) /= 0.) Kv(i,j,k) = GV%m2_s_to_HZ_T * Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) enddo endif endif diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index e26c061929..ce5adc82e2 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -147,7 +147,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) !! will be incremented here [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: KV !< Viscosity at each interface that will be - !! incremented here [Z2 T-1 ~> m2 s-1]. + !! incremented here [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_aux !< A second diapycnal diffusivity at each !! interface that will also be incremented @@ -249,7 +249,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) ! Increment the viscosity outside of the boundary layer. do K=max(1,kOBL+1),GV%ke+1 - Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * kv_col(K) + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * kv_col(K) enddo ! Store 3-d arrays for diagnostics. @@ -278,7 +278,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) ! if (CS%id_kv_conv > 0) & ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 708bb7c4fd..2e23787555 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -66,9 +66,9 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: kd !< The vertical diffusivity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: kv !< The vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous !! call to CVMix_shear_init. ! Local variables @@ -176,8 +176,8 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) do K=1,GV%ke+1 - Kvisc(K) = US%Z2_T_to_m2_s * kv(i,j,K) - Kdiff(K) = US%Z2_T_to_m2_s * kd(i,j,K) + Kvisc(K) = GV%HZ_T_to_m2_s * kv(i,j,K) + Kdiff(K) = GV%HZ_T_to_m2_s * kd(i,j,K) enddo ! Call to CVMix wrapper for computing interior mixing coefficients. @@ -187,8 +187,8 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) nlev=GV%ke, & max_nlev=GV%ke) do K=1,GV%ke+1 - kv(i,j,K) = US%m2_s_to_Z2_T * Kvisc(K) - kd(i,j,K) = US%m2_s_to_Z2_T * Kdiff(K) + kv(i,j,K) = GV%m2_s_to_HZ_T * Kvisc(K) + kd(i,j,K) = GV%m2_s_to_HZ_T * Kdiff(K) enddo enddo enddo @@ -324,9 +324,9 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) endif CS%id_kd = register_diag_field('ocean_model', 'kd_shear_CVMix', diag%axesTi, Time, & - 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_kv = register_diag_field('ocean_model', 'kv_shear_CVMix', diag%axesTi, Time, & - 'Vertical viscosity added by MOM_CVMix_shear module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Vertical viscosity added by MOM_CVMix_shear module', 'm2/s', conversion=GV%HZ_T_to_m2_s) end function CVMix_shear_init diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 466ebbabca..6e67f9f51b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -814,7 +814,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & - optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & + optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) if (CS%debug) then @@ -850,10 +850,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then Kd_add_here = Kd_ePBL(i,j,K) - visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K) else - Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) - visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) + Kd_add_here = max(Kd_ePBL(i,j,K) - GV%H_to_Z*visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K)) endif Ent_int = Kd_add_here * (GV%Z_to_H**2 * dt) / (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) @@ -1395,10 +1395,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then Kd_add_here = Kd_ePBL(i,j,K) - visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K) else - Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) - visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) + Kd_add_here = max(Kd_ePBL(i,j,K) - GV%H_to_Z*visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K)) endif Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_add_here diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 78ec0d9391..191b88de0a 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -127,15 +127,15 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kappa_io !< The diapycnal diffusivity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. Initially this is the - !! value from the previous timestep, which may + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. Initially this + !! is the value from the previous timestep, which may !! accelerate the iteration toward convergence. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: tke_io !< The turbulent kinetic energy per unit mass at !! each interface (not layer!) [Z2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kv_io !< The vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. This discards any + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s]. This discards any !! previous value (i.e. it is intent out) and !! simply sets Kv = Prandtl * Kd_shear real, intent(in) :: dt !< Time increment [T ~> s]. @@ -312,15 +312,15 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif ; enddo ! i-loop do K=1,nz+1 ; do i=is,ie - kappa_io(i,j,K) = G%mask2dT(i,j) * kappa_2d(i,K) + kappa_io(i,j,K) = G%mask2dT(i,j) * GV%Z_to_H*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 + kv_io(i,j,K) = ( G%mask2dT(i,j) * GV%Z_to_H*kappa_2d(i,K) ) * CS%Prandtl_turb enddo ; enddo enddo ! end of j-loop if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) call hchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) endif @@ -353,12 +353,13 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ !! (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: kappa_io !< The diapycnal diffusivity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & intent(out) :: tke_io !< The turbulent kinetic energy per unit mass at !! each interface (not layer!) [Z2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & - intent(inout) :: kv_io !< The vertical viscosity at each interface [Z2 T-1 ~> m2 s-1]. + intent(inout) :: kv_io !< The vertical viscosity at each interface + !! [H Z T-1 ~> m2 s-1 or Pa s]. !! The previous value is used to initialize kappa !! in the vertex columns as Kappa = Kv/Prandtl !! to accelerate the iteration toward convergence. @@ -577,11 +578,11 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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 + kv_io(I,J,K) = ( G%mask2dBu(I,J) * GV%Z_to_H*kappa_2d(I,K,J2) ) * CS%Prandtl_turb 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. - kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * & + kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * GV%Z_to_H * & ((kappa_2d(I-1,K,J2m1) + kappa_2d(I,K,J2)) + & (kappa_2d(I-1,K,J2) + kappa_2d(I,K,J2m1))) enddo ; enddo ; endif @@ -589,7 +590,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ enddo ! end of J-loop if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) call Bchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) endif @@ -1906,7 +1907,7 @@ 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, & - 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) 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) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index dfd264c92a..a83b36a377 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -310,7 +310,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i Kd_int(:,:,:) = CS%Kd if (present(Kd_extra_T)) Kd_extra_T(:,:,:) = 0.0 if (present(Kd_extra_S)) Kd_extra_S(:,:,:) = 0.0 - if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = GV%Z_to_H*CS%Kv ! Set up arrays for diagnostics. @@ -346,8 +346,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) if (associated(visc%Kv_shear)) visc%Kv_shear(:,:,:) = 0.0 ! needed for other parameterizations if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) - call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, scale=GV%HZ_T_to_m2_s) call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) endif else @@ -355,8 +355,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call calculate_kappa_shear(u_h, v_h, h, tv, fluxes%p_surf, visc%Kd_shear, visc%TKE_turb, & visc%Kv_shear, dt, G, GV, US, CS%kappaShear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) - call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) endif endif @@ -366,8 +366,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear, G, GV, US, CS%CVMix_shear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) - call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) endif elseif (associated(visc%Kv_shear)) then visc%Kv_shear(:,:,:) = 0.0 ! needed if calculate_kappa_shear is not enabled @@ -408,7 +408,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay_2d, Kd_int_2d, Kv_bkgnd, j, G, GV, US, CS%bkgnd_mixing_csp) ! Update Kv and 3-d diffusivity diagnostics. if (associated(visc%Kv_slow)) then ; do K=1,nz+1 ; do i=is,ie - visc%Kv_slow(i,j,K) = visc%Kv_slow(i,j,K) + Kv_bkgnd(i,K) + visc%Kv_slow(i,j,K) = visc%Kv_slow(i,j,K) + GV%Z_to_H*Kv_bkgnd(i,K) enddo ; enddo ; endif if (CS%id_Kv_bkgnd > 0) then ; do K=1,nz+1 ; do i=is,ie dd%Kv_bkgnd(i,j,K) = Kv_bkgnd(i,K) @@ -474,14 +474,14 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! Add the input turbulent diffusivity. if (CS%useKappaShear .or. CS%use_CVMix_shear) then do K=2,nz ; do i=is,ie - Kd_int_2d(i,K) = visc%Kd_shear(i,j,K) + 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) + Kd_int_2d(i,K) = GV%H_to_Z*visc%Kd_shear(i,j,K) + 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) enddo ; enddo do i=is,ie - Kd_int_2d(i,1) = visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. + Kd_int_2d(i,1) = GV%H_to_Z*visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. Kd_int_2d(i,nz+1) = 0.0 enddo do k=1,nz ; do i=is,ie - Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) + Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + GV%H_to_Z*0.5 * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) enddo ; enddo else do i=is,ie @@ -582,7 +582,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%debug) then if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) if (CS%use_CVMix_ddiff) then call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) @@ -591,7 +591,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) then call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, symmetric=.true., scale=US%Z2_T_to_m2_s, & + haloshift=0, symmetric=.true., scale=GV%HZ_T_to_m2_s, & scalar_pair=.true.) endif @@ -1211,7 +1211,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! Any turbulence that makes it into the mixed layers is assumed ! to be relatively small and is discarded. do i=is,ie - ustar_h = visc%ustar_BBL(i,j) + ustar_h = GV%H_to_Z*visc%ustar_BBL(i,j) if (associated(fluxes%ustar_tidal)) & ustar_h = ustar_h + fluxes%ustar_tidal(i,j) absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & @@ -1224,7 +1224,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & I2decay(i) = 0.5*CS%IMax_decay endif TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & - visc%TKE_BBL(i,j) + GV%H_to_Z*visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * I_Rho0 * & @@ -1284,7 +1284,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & else ; TKE_to_layer = 0.0 ; endif ! TKE_Ray has been initialized to 0 above. - if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & + if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * GV%H_to_Z*US%L_to_Z**2 * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1426,7 +1426,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! ! u* at the bottom [Z T-1 ~> m s-1]. - ustar = visc%ustar_BBL(i,j) + ustar = GV%H_to_Z*visc%ustar_BBL(i,j) ustar2 = ustar**2 ! In add_drag_diffusivity(), fluxes%ustar_tidal is added in. This might be double counting ! since ustar_BBL should already include all contributions to u*? -AJA @@ -1439,9 +1439,9 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int if ((ustar > 0.0) .and. (absf > CS%IMax_decay * ustar)) Idecay = absf / ustar ! Energy input at the bottom [Z3 T-3 ~> m3 s-3]. - ! (Note that visc%TKE_BBL is in [Z3 T-3 ~> m3 s-3], set in set_BBL_TKE().) + ! (Note that visc%TKE_BBL is in [H Z2 T-3 ~> m3 s-3 or W m-2], set in set_BBL_TKE().) ! I am still unsure about sqrt(cdrag) in this expressions - AJA - TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) + TKE_column = cdrag_sqrt * GV%H_to_Z*visc%TKE_BBL(i,j) ! Add in tidal dissipation energy at the bottom [Z3 T-3 ~> m3 s-3]. ! Note that TKE_tidal is in [R Z3 T-3 ~> W m-2]. if (associated(fluxes%TKE_tidal)) & @@ -1463,7 +1463,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int ! Add in additional energy input from bottom-drag against slopes (sides) if (Rayleigh_drag) TKE_remaining = TKE_remaining + & - 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & + 0.5*CS%BBL_effic * GV%H_to_Z*US%L_to_Z**2 * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1740,7 +1740,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (allocated(visc%Kv_bbl_v)) then do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then do_i(i) = .true. - vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) + vstar(i,J) = GV%H_to_Z*visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) endif ; enddo endif !### What about terms from visc%Ray? @@ -1794,7 +1794,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (allocated(visc%bbl_thick_u)) then do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then do_i(I) = .true. - ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) + ustar(I) = GV%H_to_Z*visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) endif ; enddo endif @@ -1839,12 +1839,12 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo do i=is,ie - visc%ustar_BBL(i,j) = sqrt(0.5*G%IareaT(i,j) * & + visc%ustar_BBL(i,j) = GV%Z_to_H*sqrt(0.5*G%IareaT(i,j) * & ((G%areaCu(I-1,j)*(ustar(I-1)*ustar(I-1)) + & G%areaCu(I,j)*(ustar(I)*ustar(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1)) + & G%areaCv(i,J)*(vstar(i,J)*vstar(i,J))) ) ) - visc%TKE_BBL(i,j) = US%L_to_Z**2 * & + visc%TKE_BBL(i,j) = GV%Z_to_H*US%L_to_Z**2 * & (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + & G%areaCu(I,j) * (ustar(I)*u2_bbl(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1)) + & diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 481aa5e9fc..f7b1456d46 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -964,12 +964,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then if (Rayleigh > 0.0) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) + visc%Ray_u(I,j,k) = GV%Z_to_H*Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) else ; visc%Ray_u(I,j,k) = 0.0 ; endif else if (Rayleigh > 0.0) then u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) - visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) + visc%Ray_v(i,J,k) = GV%Z_to_H*Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) else ; visc%Ray_v(i,J,k) = 0.0 ; endif endif @@ -1027,33 +1027,31 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif endif - if (CS%body_force_drag) then - if (h_bbl_drag(i) > 0.0) then - ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. - h_sum = 0.0 - I_hwtot = 1.0 / h_bbl_drag(i) - do k=nz,1,-1 - h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot - if (m==1) then - visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr - else - visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr - endif - h_sum = h_sum + h_at_vel(i,k) - if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. - enddo - ! Do not enhance the near-bottom viscosity in this case. - Kv_bbl = CS%Kv_BBL_min - endif - endif + if (CS%body_force_drag) then ; if (h_bbl_drag(i) > 0.0) then + ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. + h_sum = 0.0 + I_hwtot = 1.0 / h_bbl_drag(i) + do k=nz,1,-1 + h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot + if (m==1) then + visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + GV%Z_to_H*(CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr + else + visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + GV%Z_to_H*(CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr + endif + h_sum = h_sum + h_at_vel(i,k) + if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. + enddo + ! Do not enhance the near-bottom viscosity in this case. + Kv_bbl = CS%Kv_BBL_min + endif ; endif kv_bbl = max(CS%Kv_BBL_min, kv_bbl) if (m==1) then visc%bbl_thick_u(I,j) = bbl_thick_Z - if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = kv_bbl + if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = GV%Z_to_H*kv_bbl else visc%bbl_thick_v(i,J) = bbl_thick_Z - if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = kv_bbl + if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = GV%Z_to_H*kv_bbl endif endif ; enddo ! end of i loop enddo ; enddo ! end of m & j loops @@ -1078,10 +1076,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (CS%debug) then if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) & - call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, scale=US%Z_to_m*US%s_to_T) + call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, scale=GV%H_to_m*US%s_to_T) if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) & call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, scale=US%Z2_T_to_m2_s, scalar_pair=.true.) + haloshift=0, scale=GV%HZ_T_to_m2_s, scalar_pair=.true.) if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) & call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & G%HI, haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) @@ -1604,7 +1602,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & ( htot(I)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) visc%tbl_thick_shelf_u(I,j) = tbl_thick_Z - visc%Kv_tbl_shelf_u(I,j) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + visc%Kv_tbl_shelf_u(I,j) = GV%Z_to_H*max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) endif ; enddo ! I-loop endif ! do_any_shelf @@ -1841,7 +1839,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & ( htot(i)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) visc%tbl_thick_shelf_v(i,J) = tbl_thick_Z - visc%Kv_tbl_shelf_v(i,J) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + visc%Kv_tbl_shelf_v(i,J) = GV%Z_to_H*max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) endif ; enddo ! i-loop endif ! do_any_shelf @@ -1903,21 +1901,21 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) call safe_alloc_ptr(visc%Kd_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kd_shear, "Kd_shear", .false., restart_CS, & "Shear-driven turbulent diffusivity at interfaces", & - units="m2 s-1", conversion=US%Z2_T_to_m2_s, z_grid='i') + units="m2 s-1", conversion=GV%HZ_T_to_m2_s, z_grid='i') endif if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. & (use_kappa_shear .and. .not.KS_at_vertex )) then call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, & "Shear-driven turbulent viscosity at interfaces", & - units="m2 s-1", conversion=US%Z2_T_to_m2_s, z_grid='i') + units="m2 s-1", conversion=GV%HZ_T_to_m2_s, z_grid='i') endif if (use_kappa_shear .and. KS_at_vertex) then call safe_alloc_ptr(visc%TKE_turb, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call safe_alloc_ptr(visc%Kv_shear_Bu, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call register_restart_field(visc%Kv_shear_Bu, "Kv_shear_Bu", .false., restart_CS, & "Shear-driven turbulent viscosity at vertex interfaces", & - units="m2 s-1", conversion=US%Z2_T_to_m2_s, hor_grid="Bu", z_grid='i') + units="m2 s-1", conversion=GV%HZ_T_to_m2_s, hor_grid="Bu", z_grid='i') elseif (use_kappa_shear) then call safe_alloc_ptr(visc%TKE_turb, isd, ied, jsd, jed, nz+1) endif @@ -2277,7 +2275,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%id_bbl_thick_u = register_diag_field('ocean_model', 'bbl_thick_u', & diag%axesCu1, Time, 'BBL thickness at u points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_u = register_diag_field('ocean_model', 'kv_bbl_u', diag%axesCu1, & - Time, 'BBL viscosity at u points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + Time, 'BBL viscosity at u points', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_bbl_u = register_diag_field('ocean_model', 'bbl_u', diag%axesCu1, & Time, 'BBL mean u current', 'm s-1', conversion=US%L_T_to_m_s) if (CS%id_bbl_u>0) then @@ -2286,7 +2284,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%id_bbl_thick_v = register_diag_field('ocean_model', 'bbl_thick_v', & diag%axesCv1, Time, 'BBL thickness at v points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_v = register_diag_field('ocean_model', 'kv_bbl_v', diag%axesCv1, & - Time, 'BBL viscosity at v points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + Time, 'BBL viscosity at v points', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_bbl_v = register_diag_field('ocean_model', 'bbl_v', diag%axesCv1, & Time, 'BBL mean v current', 'm s-1', conversion=US%L_T_to_m_s) if (CS%id_bbl_v>0) then @@ -2304,9 +2302,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS allocate(visc%Ray_u(IsdB:IedB,jsd:jed,nz), source=0.0) allocate(visc%Ray_v(isd:ied,JsdB:JedB,nz), source=0.0) CS%id_Ray_u = register_diag_field('ocean_model', 'Rayleigh_u', diag%axesCuL, & - Time, 'Rayleigh drag velocity at u points', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + Time, 'Rayleigh drag velocity at u points', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_Ray_v = register_diag_field('ocean_model', 'Rayleigh_v', diag%axesCvL, & - Time, 'Rayleigh drag velocity at v points', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + Time, 'Rayleigh drag velocity at v points', 'm s-1', conversion=GV%H_to_m*US%s_to_T) endif diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 430a9225b5..57fc98834e 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -746,7 +746,7 @@ subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_T !! [Z2 T-1 ~> m2 s-1]. !! Set this to a negative value to have no limit. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & @@ -777,7 +777,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy !! frequency at the interfaces [T-2 ~> s-2]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & @@ -873,7 +873,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update viscosity with the proper unit conversion. if (associated(Kv)) then do K=1,GV%ke+1 - Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * Kv_tidal(K) ! Rescale from m2 s-1 to H Z T-1. enddo endif @@ -975,7 +975,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update viscosity if (associated(Kv)) then do K=1,GV%ke+1 - Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * Kv_tidal(K) ! Rescale from m2 s-1 to H Z T-1. enddo endif diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 496012c3d9..6af1dd78a2 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -464,7 +464,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; endif ! direct_stress if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = visc%Ray_u(I,j,k) + Ray(I,k) = GV%H_to_Z*visc%Ray_u(I,j,k) enddo ; enddo ; endif ! perform forward elimination on the tridiagonal system @@ -636,7 +636,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; endif ! direct_stress if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = visc%Ray_v(i,J,k) + Ray(i,k) = GV%H_to_Z*visc%Ray_v(i,J,k) enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then @@ -877,7 +877,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = visc%Ray_u(I,j,k) + Ray(I,k) = GV%H_to_Z*visc%Ray_u(I,j,k) enddo ; enddo ; endif do I=Isq,Ieq ; if (do_i(I)) then @@ -906,7 +906,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = visc%Ray_v(i,J,k) + Ray(i,k) = GV%H_to_Z*visc%Ray_v(i,J,k) enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then @@ -1070,7 +1070,7 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do I=Isq,Ieq - kv_bbl(I) = visc%Kv_bbl_u(I,j) + kv_bbl(I) = GV%H_to_Z*visc%Kv_bbl_u(I,j) bbl_thick(I) = visc%bbl_thick_u(I,j) * GV%Z_to_H + h_neglect if (do_i(I)) I_Hbbl(I) = 1.0 / bbl_thick(I) enddo ; endif @@ -1263,7 +1263,7 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do i=is,ie - kv_bbl(i) = visc%Kv_bbl_v(i,J) + kv_bbl(i) = GV%H_to_Z*visc%Kv_bbl_v(i,J) bbl_thick(i) = visc%bbl_thick_v(i,J) * GV%Z_to_H + h_neglect if (do_i(i)) I_Hbbl(i) = 1.0 / bbl_thick(i) enddo ; endif @@ -1609,14 +1609,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! layer thicknesses or the surface wind stresses are added later. if (work_on_u) then do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) + Kv_add(i,K) = GV%H_to_Z*0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) endif ; enddo ; enddo if (do_OBCs) then do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j,k) ; enddo elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i+1,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i+1,j,k) ; enddo endif endif ; enddo endif @@ -1625,14 +1625,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif ; enddo ; enddo else do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) + Kv_add(i,K) = GV%H_to_Z*0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) endif ; enddo ; enddo if (do_OBCs) then do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j,k) ; enddo elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j+1,k) ; enddo + do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j+1,k) ; enddo endif endif ; enddo endif @@ -1648,11 +1648,11 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! to further modify these viscosities here to take OBCs into account. if (work_on_u) then do K=2,nz ; do I=Is,Ie ; If (do_i(I)) then - Kv_tot(I,K) = Kv_tot(I,K) + (0.5)*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) + Kv_tot(I,K) = Kv_tot(I,K) + GV%H_to_Z*(0.5)*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) endif ; enddo ; enddo else do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + (0.5)*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) + Kv_tot(i,K) = Kv_tot(i,K) + GV%H_to_Z*(0.5)*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) endif ; enddo ; enddo endif endif @@ -1726,10 +1726,10 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! Set the coefficients to include the no-slip surface stress. do i=is,ie ; if (do_i(i)) then if (work_on_u) then - kv_TBL(i) = visc%Kv_tbl_shelf_u(I,j) + kv_TBL(i) = GV%H_to_Z*visc%Kv_tbl_shelf_u(I,j) tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) * GV%Z_to_H + h_neglect else - kv_TBL(i) = visc%Kv_tbl_shelf_v(i,J) + kv_TBL(i) = GV%H_to_Z*visc%Kv_tbl_shelf_v(i,J) tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) * GV%Z_to_H + h_neglect endif z_t(i) = 0.0 @@ -2440,7 +2440,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0 CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & - 'Slow varying vertical viscosity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Slow varying vertical viscosity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & 'Total vertical viscosity at u-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) From 2d42dcacfc8e1773e900a3520339ab3c1ce0f5a5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 16 Jul 2023 18:57:51 -0400 Subject: [PATCH 029/146] +Thickness-based diffusivity arguments Rescaled diapycnal diffusivities passed as arguments in non-Boussinesq mode, to be equivalent to the thermal conductivity divided by the heat capacity, analogously to the difference between a kinematic viscosity and a dynamic viscosity, so that the new units are [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. This includes changing the units of 4 arguments to set_diffusivity; 3 arguments each to calculate_bkgnd_mixing, add_drag_diffusivity, add_LOTW_BBL_diffusivity, user_change_diff, calculate_tidal_mixing and add_int_tide_diffusivity; 2 arguments to KPP_calculate, calculate_CVMix_conv, compute_ddiff_coeffs, differential_diffuse_T_S, entrainment_diffusive, double_diffusion, add_MLrad_diffusivity, and calculate_CVMix_tidal; and one argument to energetic_PBL. The units of 36 internal variables were also changed, as were a total of 29 elements in various opaque types, including 8 elements in bkgnd_mixing_cs, 2 in diabatic_CC, 3 in tidal_mixing_diags type, 1 in user_change_diff_CS, 9 in set_diffusivity_CS type, and 6 elements in diffusivity_diags. Two new internal variables were added, and several redundant GV%H_to_Z conversion factors were also cancelled out, some using that GV%H_to_Z*GV%Rho0 = GV%H_to_RZ. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode unless GV%Rho_0 is chosen to be an integer power of 2. --- .../vertical/MOM_CVMix_KPP.F90 | 26 +-- .../vertical/MOM_CVMix_conv.F90 | 15 +- .../vertical/MOM_CVMix_ddiff.F90 | 10 +- .../vertical/MOM_bkgnd_mixing.F90 | 81 +++---- .../vertical/MOM_diabatic_aux.F90 | 12 +- .../vertical/MOM_diabatic_driver.F90 | 150 ++++++------ .../vertical/MOM_energetic_PBL.F90 | 4 +- .../vertical/MOM_entrain_diffusive.F90 | 14 +- .../vertical/MOM_set_diffusivity.F90 | 215 +++++++++--------- .../vertical/MOM_tidal_mixing.F90 | 90 ++++---- src/user/user_change_diffusivity.F90 | 16 +- 11 files changed, 327 insertions(+), 306 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index f5d30029f1..5e56098c98 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -536,7 +536,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) 'Heat diffusivity due to KPP, as calculated by [CVMix] KPP', & 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_Kd_in = register_diag_field('ocean_model', 'KPP_Kd_in', diag%axesTi, Time, & - 'Diffusivity passed to KPP', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Diffusivity passed to KPP', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_Ks_KPP = register_diag_field('ocean_model', 'KPP_Ksalt', diag%axesTi, Time, & 'Salt diffusivity due to KPP, as calculated by [CVMix] KPP', & 'm2/s', conversion=US%Z2_T_to_m2_s) @@ -610,10 +610,10 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP !! (out) Vertical diffusivity including KPP - !! [Z2 T-1 ~> m2 s-1] + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP !! (out) Vertical diffusivity including KPP - !! [Z2 T-1 ~> m2 s-1] + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP !! (out) Vertical viscosity including KPP !! [H Z T-1 ~> m2 s-1 or Pa s] @@ -650,8 +650,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & 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) call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) - 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) + call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) endif nonLocalTrans(:,:) = 0.0 @@ -711,8 +711,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt [m2 s-1] Kviscosity(:) = 0. ! Viscosity [m2 s-1] else - Kdiffusivity(:,1) = US%Z2_T_to_m2_s * Kt(i,j,:) - Kdiffusivity(:,2) = US%Z2_T_to_m2_s * Ks(i,j,:) + Kdiffusivity(:,1) = GV%HZ_T_to_m2_s * Kt(i,j,:) + Kdiffusivity(:,2) = GV%HZ_T_to_m2_s * Ks(i,j,:) Kviscosity(:) = GV%HZ_T_to_m2_s * Kv(i,j,:) endif @@ -860,15 +860,15 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & if (.not. CS%passiveMode) then if (CS%KPPisAdditive) then do k=1, GV%ke+1 - Kt(i,j,k) = Kt(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,1) - Ks(i,j,k) = Ks(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,2) + Kt(i,j,k) = Kt(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,1) + Ks(i,j,k) = Ks(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,2) Kv(i,j,k) = Kv(i,j,k) + GV%m2_s_to_HZ_T * Kviscosity(k) if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) enddo else ! KPP replaces prior diffusivity when former is non-zero do k=1, GV%ke+1 - if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,1) - if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,2) + if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,1) + if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,2) if (Kviscosity(k) /= 0.) Kv(i,j,k) = GV%m2_s_to_HZ_T * Kviscosity(k) if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) enddo @@ -883,8 +883,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & call cpu_clock_end(id_clock_KPP_calc) 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) + call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index ce5adc82e2..c95b967681 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -143,15 +143,16 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) type(CVMix_conv_cs), intent(in) :: CS !< CVMix convection control structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hbl !< Depth of ocean boundary layer [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: Kd !< Diapycnal diffusivity at each interface that - !! will be incremented here [Z2 T-1 ~> m2 s-1]. + intent(inout) :: Kd !< Diapycnal diffusivity at each interface + !! that will be incremented here + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: KV !< Viscosity at each interface that will be + intent(inout) :: Kv !< Viscosity at each interface that will be !! incremented here [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_aux !< A second diapycnal diffusivity at each !! interface that will also be incremented - !! here [Z2 T-1 ~> m2 s-1]. + !! here [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! local variables real, dimension(SZK_(GV)) :: rho_lwr !< Adiabatic Water Density [kg m-3], this is a dummy @@ -238,12 +239,12 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) ! Increment the diffusivity outside of the boundary layer. do K=max(1,kOBL+1),GV%ke+1 - Kd(i,j,K) = Kd(i,j,K) + US%m2_s_to_Z2_T * kd_col(K) + Kd(i,j,K) = Kd(i,j,K) + GV%m2_s_to_HZ_T * kd_col(K) enddo if (present(Kd_aux)) then ! Increment the other diffusivity outside of the boundary layer. do K=max(1,kOBL+1),GV%ke+1 - Kd_aux(i,j,K) = Kd_aux(i,j,K) + US%m2_s_to_Z2_T * kd_col(K) + Kd_aux(i,j,K) = Kd_aux(i,j,K) + GV%m2_s_to_HZ_T * kd_col(K) enddo endif @@ -277,7 +278,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) ! call hchksum(Kd_conv, "MOM_CVMix_conv: Kd_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) ! if (CS%id_kv_conv > 0) & ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 6e2c76ba8d..c2bf357559 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -150,9 +150,11 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) integer, intent(in) :: j !< Meridional grid index to work on. ! Kd_T and Kd_S are intent inout because only one j-row is set here, but they are essentially outputs. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd_T !< Interface double diffusion diapycnal - !! diffusivity for temp [Z2 T-1 ~> m2 s-1]. + !! diffusivity for temperature + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd_S !< Interface double diffusion diapycnal - !! diffusivity for salt [Z2 T-1 ~> m2 s-1]. + !! diffusivity for salinity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(CVMix_ddiff_cs), pointer :: CS !< The control structure returned !! by a previous call to CVMix_ddiff_init. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & @@ -254,8 +256,8 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) nlev=GV%ke, & max_nlev=GV%ke) do K=1,GV%ke+1 - Kd_T(i,j,K) = US%m2_s_to_Z2_T * Kd1_T(K) - Kd_S(i,j,K) = US%m2_s_to_Z2_T * Kd1_S(K) + Kd_T(i,j,K) = GV%m2_s_to_HZ_T * Kd1_T(K) + Kd_S(i,j,K) = GV%m2_s_to_HZ_T * Kd1_S(K) enddo ! Do not apply mixing due to convection within the boundary layer diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 01f8303ae2..693b9395bd 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -45,15 +45,15 @@ module MOM_bkgnd_mixing real :: Bryan_Lewis_c4 !< The depth where diffusivity is Bryan_Lewis_bl1 in the !! Bryan-Lewis profile [Z ~> m] real :: bckgrnd_vdc1 !< Background diffusivity (Ledwell) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: bckgrnd_vdc_eq !< Equatorial diffusivity (Gregg) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: bckgrnd_vdc_psim !< Max. PSI induced diffusivity (MacKinnon) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: bckgrnd_vdc_Banda !< Banda Sea diffusivity (Gordon) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] - real :: Kd_min !< minimum diapycnal diffusivity [Z2 T-1 ~> m2 s-1] - real :: Kd !< interior diapycnal diffusivity [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: N0_2Omega !< ratio of the typical Buoyancy frequency to !! twice the Earth's rotation period, used with the @@ -63,10 +63,10 @@ module MOM_bkgnd_mixing real :: Kd_tanh_lat_scale !< A nondimensional scaling for the range of !! diffusivities with Kd_tanh_lat_fn [nondim]. Valid values !! are in the range of -2 to 2; 0.4 reproduces CM2M. - real :: Kd_tot_ml !< The mixed layer diapycnal diffusivity [Z2 T-1 ~> m2 s-1] + real :: Kd_tot_ml !< The mixed layer diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !! when no other physically based mixed layer turbulence !! parameterization is being used. - real :: Hmix !< mixed layer thickness [Z ~> m] when no physically based + real :: Hmix !< mixed layer thickness [H ~> m or kg m-2] when no physically based !! ocean surface boundary layer parameterization is used. logical :: Kd_tanh_lat_fn !< If true, use the tanh dependence of Kd_sfc on !! latitude, like GFDL CM2.1/CM2M. There is no @@ -114,8 +114,10 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL !! surface boundary layer. ! Local variables - real :: Kv ! The interior vertical viscosity [Z2 T-1 ~> m2 s-1] - read to set Prandtl + real :: Kv ! The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] - read to set Prandtl ! number unless it is provided as a parameter + real :: Kd_z ! The background diapycnal diffusivity in [Z2 T-1 ~> m2 s-1] for use + ! in setting the default for other diffusivities. real :: prandtl_bkgnd_comp ! Kv/CS%Kd [nondim]. Gets compared with user-specified prandtl_bkgnd. ! This include declares and sets the variable "version". @@ -132,19 +134,20 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL call log_version(param_file, mdl, version, & "Adding static vertical background mixing coefficients") - call get_param(param_file, mdl, "KD", CS%Kd, & + call get_param(param_file, mdl, "KD", Kd_z, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + CS%Kd = (GV%m2_s_to_HZ_T*US%Z2_T_to_m2_s) * Kd_z call get_param(param_file, mdl, "KV", Kv, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + units="m2 s-1", scale=GV%m2_s_to_HZ_T, fail_if_missing=.true.) call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) ! The following is needed to set one of the choices of vertical background mixing @@ -152,11 +155,11 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL if (CS%physical_OBL_scheme) then ! Check that Kdml is not set when using bulk mixed layer call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, & - units="m2 s-1", default=-1., scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=-1., scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & "bkgnd_mixing_init: KDML is a depricated parameter that should not be used.") call get_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & - units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & "bkgnd_mixing_init: KD_ML_TOT cannot be set when using a physically based ocean "//& "boundary layer mixing parameterization.") @@ -166,13 +169,13 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL "The total diapcynal diffusivity in the surface mixed layer when there is "//& "not a physically based parameterization of mixing in the mixed layer, such "//& "as bulk mixed layer or KPP or ePBL.", & - units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (abs(CS%Kd_tot_ml - CS%Kd) <= 1.0e-15*abs(CS%Kd)) then call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, & "If BULKMIXEDLAYER is false, KDML is the elevated "//& "diapycnal diffusivity in the topmost HMIX of fluid. "//& "KDML is only used if BULKMIXEDLAYER is false.", & - units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (abs(CS%Kd_tot_ml - CS%Kd) > 1.0e-15*abs(CS%Kd)) & call MOM_error(WARNING, "KDML is a depricated parameter. Use KD_ML_TOT instead.") endif @@ -180,12 +183,12 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL "The total diapcynal diffusivity in the surface mixed layer when there is "//& "not a physically based parameterization of mixing in the mixed layer, such "//& "as bulk mixed layer or KPP or ePBL.", & - units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, unscale=US%Z2_T_to_m2_s) + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, unscale=GV%HZ_T_to_m2_s) call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & "The prescribed depth over which the near-surface "//& "viscosity and diffusivity are elevated when the bulk "//& - "mixed layer is not used.", units="m", scale=US%m_to_Z, fail_if_missing=.true.) + "mixed layer is not used.", units="m", scale=GV%m_to_H, fail_if_missing=.true.) endif call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) @@ -228,19 +231,19 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL call get_param(param_file, mdl, "BCKGRND_VDC1", CS%bckgrnd_vdc1, & "Background diffusivity (Ledwell) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.16e-04, scale=US%m2_s_to_Z2_T) + units="m2 s-1",default = 0.16e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_EQ", CS%bckgrnd_vdc_eq, & "Equatorial diffusivity (Gregg) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.01e-04, scale=US%m2_s_to_Z2_T) + units="m2 s-1",default = 0.01e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_PSIM", CS%bckgrnd_vdc_psim, & "Max. PSI induced diffusivity (MacKinnon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.13e-4, scale=US%m2_s_to_Z2_T) + units="m2 s-1",default = 0.13e-4, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_BAN", CS%bckgrnd_vdc_Banda, & "Banda Sea diffusivity (Gordon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 1.0e-4, scale=US%m2_s_to_Z2_T) + units="m2 s-1",default = 1.0e-4, scale=GV%m2_s_to_HZ_T) endif call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & @@ -318,12 +321,12 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< squared buoyancy frequency associated !! with layers [T-2 ~> s-2] - real, dimension(SZI_(G),SZK_(GV)), intent(out) :: Kd_lay !< The background diapycnal diffusivity - !! of each layer [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_int !< The background diapycnal diffusivity - !! of each interface [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: Kd_lay !< The background diapycnal diffusivity of each + !! layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_int !< The background diapycnal diffusivity of each + !! interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kv_bkgnd !< The background vertical viscosity at - !! each interface [Z2 T-1 ~> m2 s-1] + !! each interface [H Z T-1 ~> m2 s-1 or Pa s] integer, intent(in) :: j !< Meridional grid index type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(bkgnd_mixing_cs), pointer :: CS !< The control structure returned by @@ -333,10 +336,10 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, real, dimension(SZK_(GV)+1) :: depth_int !< Distance from surface of the interfaces [m] real, dimension(SZK_(GV)+1) :: Kd_col !< Diffusivities at the interfaces [m2 s-1] real, dimension(SZK_(GV)+1) :: Kv_col !< Viscosities at the interfaces [m2 s-1] - real, dimension(SZI_(G)) :: Kd_sfc !< Surface value of the diffusivity [Z2 T-1 ~> m2 s-1] - real, dimension(SZI_(G)) :: depth !< Distance from surface of an interface [Z ~> m] - real :: depth_c !< depth of the center of a layer [Z ~> m] - real :: I_Hmix !< inverse of fixed mixed layer thickness [Z-1 ~> m-1] + real, dimension(SZI_(G)) :: Kd_sfc !< Surface value of the diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G)) :: depth !< Distance from surface of an interface [H ~> m or kg m-2] + real :: depth_c !< depth of the center of a layer [H ~> m or kg m-2] + real :: I_Hmix !< inverse of fixed mixed layer thickness [H-1 ~> m-1 or m2 kg-1] real :: I_2Omega !< 1/(2 Omega) [T ~> s] real :: N_2Omega ! The ratio of the stratification to the Earth's rotation rate [nondim] real :: N02_N2 ! The ratio a reference stratification to the actual stratification [nondim] @@ -344,8 +347,8 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, real :: deg_to_rad !< factor converting degrees to radians [radians degree-1], pi/180. real :: abs_sinlat !< absolute value of sine of latitude [nondim] real :: min_sinlat ! The minimum value of the sine of latitude [nondim] - real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere [Z2 T-1 ~> m2 s-1] - real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere [Z2 T-1 ~> m2 s-1] + real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere [H Z T-1 ~> m2 s-1 or kg m-1 s-1] integer :: i, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -380,11 +383,11 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, ! Update Kd and Kv. do K=1,nz+1 - Kv_bkgnd(i,K) = US%m2_s_to_Z2_T*Kv_col(K) - Kd_int(i,K) = US%m2_s_to_Z2_T*Kd_col(K) + Kv_bkgnd(i,K) = GV%m2_s_to_HZ_T * Kv_col(K) + Kd_int(i,K) = GV%m2_s_to_HZ_T*Kd_col(K) enddo do k=1,nz - Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_col(K) + Kd_col(K+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_col(K) + Kd_col(K+1)) enddo enddo ! i loop @@ -461,10 +464,10 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, if ((.not.CS%physical_OBL_scheme) .and. (CS%Kd /= CS%Kd_tot_ml)) then ! This is a crude way to put in a diffusive boundary layer without an explicit boundary ! layer turbulence scheme. It should not be used for any realistic ocean models. - I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff*GV%H_to_Z) + I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff) do i=is,ie ; depth(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - depth_c = depth(i) + 0.5*GV%H_to_Z*h(i,j,k) + depth_c = depth(i) + 0.5*h(i,j,k) if (CS%Kd_via_Kdml_bug) then ! These two lines should update Kd_lay, not Kd_int. They were correctly working on the ! same variables until MOM6 commit 7a818716 (PR#750), which was added on March 26, 2018. @@ -481,7 +484,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, endif endif - depth(i) = depth(i) + GV%H_to_Z*h(i,j,k) + depth(i) = depth(i) + h(i,j,k) enddo ; enddo else ! There is no vertical structure to the background diffusivity. diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 009cdc4075..f176b0d726 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -239,11 +239,11 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: Kd_T !< The extra diffusivity of temperature due to !! double diffusion relative to the diffusivity of - !! diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! density [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: Kd_S !< The extra diffusivity of salinity due to !! double diffusion relative to the diffusivity of - !! diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! density [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any !! available thermodynamic fields. real, intent(in) :: dt !< Time increment [T ~> s]. @@ -272,8 +272,8 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) do j=js,je do i=is,ie I_h_int = 1.0 / (0.5 * (h(i,j,1) + h(i,j,2)) + h_neglect) - mix_T(i,2) = ((dt * Kd_T(i,j,2)) * GV%Z_to_H**2) * I_h_int - mix_S(i,2) = ((dt * Kd_S(i,j,2)) * GV%Z_to_H**2) * I_h_int + mix_T(i,2) = ((dt * Kd_T(i,j,2)) * GV%Z_to_H) * I_h_int + mix_S(i,2) = ((dt * Kd_S(i,j,2)) * GV%Z_to_H) * I_h_int h_tr = h(i,j,1) + h_neglect b1_T(i) = 1.0 / (h_tr + mix_T(i,2)) @@ -286,8 +286,8 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) do k=2,nz-1 ; do i=is,ie ! Calculate the mixing across the interface below this layer. I_h_int = 1.0 / (0.5 * (h(i,j,k) + h(i,j,k+1)) + h_neglect) - mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1)) * GV%Z_to_H**2) * I_h_int - mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1)) * GV%Z_to_H**2) * I_h_int + mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1)) * GV%Z_to_H) * I_h_int + mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1)) * GV%Z_to_H) * I_h_int c1_T(i,k) = mix_T(i,K) * b1_T(i) c1_S(i,k) = mix_S(i,K) * b1_S(i) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 6e67f9f51b..631a47c259 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -145,11 +145,11 @@ module MOM_diabatic_driver !! diffusivity of Kd_min_tr (see below) were operating. real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes - !! [Z2 T-1 ~> m2 s-1]. The entrainment at the bottom is at + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. The entrainment at the bottom is at !! least sqrt(Kd_BBL_tr*dt) over the same distance. real :: Kd_min_tr !< A minimal diffusivity that should always be !! applied to tracers, especially in massless layers - !! near the bottom [Z2 T-1 ~> m2 s-1]. + !! near the bottom [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: minimum_forcing_depth !< The smallest depth over which heat and freshwater !! fluxes are applied [H ~> m or kg m-2]. real :: evap_CFL_limit = 0.8 !< The largest fraction of a layer that can be @@ -543,14 +543,14 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! salinity and passive tracers [H ~> m or kg m-2] ent_t, & ! The diffusive coupling across interfaces within one time step for ! temperature [H ~> m or kg m-2] - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] - Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_heat, & ! diapycnal diffusivity of heat [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. - Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -569,7 +569,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] - real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] @@ -638,7 +638,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif ! Set diffusivities for heat and salt separately @@ -659,8 +659,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%debug) then - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif call cpu_clock_begin(id_clock_kpp) @@ -673,17 +673,17 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! unlike other instances where the fluxes are integrated in time over a time-step. call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) - ! The KPP scheme calculates boundary layer diffusivities and non-local transport. + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) @@ -719,8 +719,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & scale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & @@ -783,7 +783,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !$OMP parallel do default(shared) private(I_hval) do K=2,nz ; do j=js,je ; do i=is,ie I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_s(i,j,K) = (GV%Z_to_H**2) * dt * I_hval * Kd_int(i,j,K) + ent_s(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_int(i,j,K) ent_t(i,j,K) = ent_s(i,j,K) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_s and ent_t from Kd_int (diabatic)") @@ -818,8 +818,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) if (CS%debug) then - call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_mks) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_mks) call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & scale=US%RZ3_T3_to_W_m2*US%T_to_s) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & @@ -850,13 +850,13 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then Kd_add_here = Kd_ePBL(i,j,K) - visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) else - Kd_add_here = max(Kd_ePBL(i,j,K) - GV%H_to_Z*visc%Kd_shear(i,j,K), 0.0) - visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K)) + Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) endif - Ent_int = Kd_add_here * (GV%Z_to_H**2 * dt) / (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) + Ent_int = Kd_add_here * (GV%Z_to_H * dt) / (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) ent_s(i,j,K) = ent_s(i,j,K) + Ent_int Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here @@ -869,7 +869,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (CS%debug) then call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif else @@ -1002,7 +1002,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je @@ -1021,7 +1021,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_int, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & ((h(i,j,k-1)+h(i,j,k)+h_neglect) / (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & 0.5*(ent_s(i,j,K) + ent_s(i,j,K)) if (htot(i) < Tr_ea_BBL) then @@ -1034,7 +1034,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H) / & (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) ent_s(i,j,K) = ent_s(i,j,K) + add_ent endif ; endif @@ -1045,7 +1045,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H) / & (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) else add_ent = 0.0 @@ -1140,13 +1140,13 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ent_t, & ! The diffusive coupling across interfaces within one time step for ! temperature [H ~> m or kg m-2] Kd_heat, & ! diapycnal diffusivity of heat or the smaller of the diapycnal diffusivities of - ! heat and salt [Z2 T-1 ~> m2 s-1] - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] + ! heat and salt [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to - ! Kd_int returned from set_diffusivity [Z2 T-1 ~> m2 s-1]. + ! Kd_int returned from set_diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to - ! Kd_int returned from set_diffusivity [Z2 T-1 ~> m2 s-1]. - Kd_ePBL, & ! boundary layer or convective diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] + ! Kd_int returned from set_diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ePBL, & ! boundary layer or convective diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -1166,7 +1166,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. - real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: Idt ! The inverse time step [T-1 ~> s-1] logical :: showCallTree ! If true, show the call tree @@ -1235,7 +1235,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif ! Store the diagnosed typical diffusivity at interfaces. @@ -1257,8 +1257,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif if (CS%debug) then - call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif if (CS%useKPP) then @@ -1307,8 +1307,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & scale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & @@ -1395,10 +1395,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then Kd_add_here = Kd_ePBL(i,j,K) - visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) else - Kd_add_here = max(Kd_ePBL(i,j,K) - GV%H_to_Z*visc%Kd_shear(i,j,K), 0.0) - visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K)) + Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) endif Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_add_here @@ -1408,7 +1408,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%debug) then call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif else @@ -1473,8 +1473,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, !$OMP parallel do default(shared) private(I_hval) do K=2,nz ; do j=js,je ; do i=is,ie I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_t(i,j,K) = (GV%Z_to_H**2) * dt * I_hval * Kd_heat(i,j,k) - ent_s(i,j,K) = (GV%Z_to_H**2) * dt * I_hval * Kd_salt(i,j,k) + ent_t(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_heat(i,j,k) + ent_s(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_salt(i,j,k) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_t and ent_t from Kd_heat and " //& "Kd_salt (diabatic_ALE)") @@ -1505,14 +1505,14 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call diag_update_remap_grids(CS%diag) ! Diagnose the diapycnal diffusivities and other related quantities. - if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) - if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) - if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) + if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) + if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) - if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) - if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) - if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ent_s(:,:,1:nz), CS%diag) - if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, ent_s(:,:,2:nz+1), CS%diag) + if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) + if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) + if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ent_s(:,:,1:nz), CS%diag) + if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, ent_s(:,:,2:nz+1), CS%diag) Idt = 1.0 / dt if (CS%id_Tdif > 0) then @@ -1540,7 +1540,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -1554,7 +1554,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! bottom, add some mixing of tracers between these layers. This flux is based on the ! harmonic mean of the two thicknesses, following what is done in layered mode. Kd_min_tr ! should be much less than the values in Kd_salt, perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & ((h(i,j,k-1)+h(i,j,k) + h_neglect) / (h(i,j,k-1)*h(i,j,k) + h_neglect2)) - & ent_s(i,j,K) if (htot(i) < Tr_ea_BBL) then @@ -1646,7 +1646,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! one time step [H ~> m or kg m-2] eb, & ! amount of fluid entrained from the layer below within ! one time step [H ~> m or kg m-2] - Kd_lay, & ! diapycnal diffusivity of layers [Z2 T-1 ~> m2 s-1] + Kd_lay, & ! diapycnal diffusivity of layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] hold, & ! layer thickness before diapycnal entrainment, and later the initial ! layer thicknesses (if a mixed layer is used) [H ~> m or kg m-2] @@ -1665,13 +1665,13 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! homogenize tracers in massless layers near the boundaries [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] - Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_heat, & ! diapycnal diffusivity of heat [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Tadv_flx, & ! advective diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -1852,8 +1852,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif @@ -1930,8 +1930,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif if (.not.associated(fluxes%KPP_salt_flux)) fluxes%KPP_salt_flux => CS%KPP_salt_flux endif ! endif for KPP @@ -2301,7 +2301,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! mixing of passive tracers from massless boundary layers to interior call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracers) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -2320,7 +2320,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_lay, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & 0.5*(ea(i,j,k) + eb(i,j,k-1)) @@ -2337,7 +2337,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H**2) / & + add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & h_neglect) ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent @@ -2361,7 +2361,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H**2) / & + add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & h_neglect) else @@ -3090,12 +3090,12 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "A minimal diffusivity that should always be applied to "//& "tracers, especially in massless layers near the bottom. "//& "The default is 0.1*KD.", & - units="m2 s-1", default=0.1*Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.1*Kd*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KD_BBL_TR", CS%Kd_BBL_tr, & "A bottom boundary layer tracer diffusivity that will "//& "allow for explicitly specified bottom fluxes. The "//& "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) "//& - "over the same distance.", units="m2 s-1", default=0., scale=US%m2_s_to_Z2_T) + "over the same distance.", units="m2 s-1", default=0., scale=GV%m2_s_to_HZ_T) endif call get_param(param_file, mdl, "TRACER_TRIDIAG", CS%tracer_tridiag, & @@ -3242,19 +3242,19 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif CS%id_Kd_int = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & - 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_energetic_PBL) then CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & - 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif CS%id_Kd_heat = register_diag_field('ocean_model', 'Kd_heat', diag%axesTi, Time, & - 'Total diapycnal diffusivity for heat at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s, & + 'Total diapycnal diffusivity for heat at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s, & cmor_field_name='difvho', & cmor_standard_name='ocean_vertical_heat_diffusivity', & cmor_long_name='Ocean vertical heat diffusivity') CS%id_Kd_salt = register_diag_field('ocean_model', 'Kd_salt', diag%axesTi, Time, & - 'Total diapycnal diffusivity for salt at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s, & + 'Total diapycnal diffusivity for salt at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s, & cmor_field_name='difvso', & cmor_standard_name='ocean_vertical_salt_diffusivity', & cmor_long_name='Ocean vertical salt diffusivity') diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 641816513c..2c2f94519a 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -277,7 +277,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. @@ -467,7 +467,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS CS%ML_depth(i,j) = 0.0 endif ; enddo ! Close of i-loop - Note unusual loop order! - do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = Kd_2d(i,K) ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = GV%Z_to_H*Kd_2d(i,K) ; enddo ; enddo enddo ! j-loop diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 51a28db0e9..c30f5c2c3f 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -78,10 +78,10 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! At least one of the two following arguments must be present. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This subroutine calculates ea and eb, the rates at which a layer entrains ! from the layers above and below. The entrainment rates are proportional to @@ -274,23 +274,23 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & if (present(Kd_Lay)) then do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (dt * Kd_lay(i,j,k)) + dtKd(i,k) = GV%Z_to_H * (dt * Kd_lay(i,j,k)) enddo ; enddo if (present(Kd_int)) then do K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt * Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) enddo ; enddo else do K=2,nz ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (0.5 * dt * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k))) + dtKd_int(i,K) = GV%Z_to_H * (0.5 * dt * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k))) enddo ; enddo endif else ! Kd_int must be present, or there already would have been an error. do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (0.5 * dt * (Kd_int(i,j,K)+Kd_int(i,j,K+1))) + dtKd(i,k) = GV%Z_to_H * (0.5 * dt * (Kd_int(i,j,K)+Kd_int(i,j,K+1))) enddo ; enddo dO K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt * Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) enddo ; enddo endif diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index a83b36a377..97a34ddbcb 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -79,13 +79,13 @@ module MOM_set_diffusivity real :: cdrag !< quadratic drag coefficient [nondim] real :: IMax_decay !< inverse of a maximum decay scale for !! bottom-drag driven turbulence [Z-1 ~> m-1]. - real :: Kv !< The interior vertical viscosity [Z2 T-1 ~> m2 s-1]. - real :: Kd !< interior diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Kd_min !< minimum diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Kd_max !< maximum increment for diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] + real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_max !< maximum increment for diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !! Set to a negative value to have no limit. real :: Kd_add !< uniform diffusivity added everywhere without - !! filtering or scaling [Z2 T-1 ~> m2 s-1]. + !! filtering or scaling [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: Kd_smooth !< Vertical diffusivity used to interpolate more !! sensible values of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing @@ -96,7 +96,7 @@ module MOM_set_diffusivity real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [R Z2 T-3 ~> W m-3] real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [R Z2 T-2 ~> J m-3] real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [R Z2 T-1 ~> J s m-3] - real :: dissip_Kd_min !< Minimum Kd [Z2 T-1 ~> m2 s-1], with dissipation Rho0*Kd_min*N^2 + real :: dissip_Kd_min !< Minimum Kd [H Z T-1 ~> m2 s-1 or kg m-1 s-1], with dissipation Rho0*Kd_min*N^2 real :: omega !< Earth's rotation frequency [T-1 ~> s-1] logical :: ML_radiation !< allow a fraction of TKE available from wind work @@ -112,8 +112,8 @@ module MOM_set_diffusivity !! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), !! where N2 is the squared buoyancy frequency [T-2 ~> s-2] and OMEGA2 !! is the rotation rate of the earth squared. - real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence - !! radiated from the base of the mixed layer [Z2 T-1 ~> m2 s-1]. + real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence radiated from + !! the base of the mixed layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: ML_rad_efold_coeff !< Coefficient to scale penetration depth [nondim] real :: ML_rad_coeff !< Coefficient which scales MSTAR*USTAR^3 to obtain energy !! available for mixing below mixed layer base [nondim] @@ -148,8 +148,8 @@ module MOM_set_diffusivity logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that !! does not rely on a layer-formulation. real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering [nondim] - real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [Z2 T-1 ~> m2 s-1] - real :: Kv_molecular !< Molecular viscosity for double diffusive convection [Z2 T-1 ~> m2 s-1] + real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kv_molecular !< Molecular viscosity for double diffusive convection [H Z T-1 ~> m2 s-1 or Pa s] integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's !! calculations. Values below 20190101 recover the answers from the @@ -178,19 +178,19 @@ module MOM_set_diffusivity type diffusivity_diags real, pointer, dimension(:,:,:) :: & N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] - Kd_user => NULL(), & !< user-added diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [Z2 T-1 ~> m2 s-1] + Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] maxTKE => NULL(), & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] - Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [Z2 T-1 ~> m2 s-1]. - KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [Z2 T-1 ~> m2 s-1]. + Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] + KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] drho_rat => NULL() !< The density difference ratio used in double diffusion [nondim]. real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE !! dissipated within a layer and Kd in that layer - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] end type diffusivity_diags @@ -224,18 +224,22 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i !! boundary layer properties and related fields. real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(out) :: Kd_int !< Diapycnal diffusivity at each interface [Z2 T-1 ~> m2 s-1]. + intent(out) :: Kd_int !< Diapycnal diffusivity at each interface + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 T-1 ~> m2 s-1]. + optional, intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(out) :: Kd_extra_T !< The extra diffusivity at interfaces of - !! temperature due to double diffusion relative to - !! the diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! temperature due to double diffusion relative + !! to the diffusivity of density + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(out) :: Kd_extra_S !< The extra diffusivity at interfaces of - !! salinity due to double diffusion relative to - !! the diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! salinity due to double diffusion relative + !! to the diffusivity of density + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! local variables real, dimension(SZI_(G)) :: & @@ -249,19 +253,19 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i real, dimension(SZI_(G),SZK_(GV)) :: & N2_lay, & !< Squared buoyancy frequency associated with layers [T-2 ~> s-2] - Kd_lay_2d, & !< The layer diffusivities [Z2 T-1 ~> m2 s-1] + Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] maxTKE, & !< Energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer - !< [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !< [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)+1) :: & N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] - Kd_int_2d, & !< The interface diffusivities [Z2 T-1 ~> m2 s-1] - Kv_bkgnd, & !< The background diffusion related interface viscosities [Z2 T-1 ~> m2 s-1] + Kd_int_2d, & !< The interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd, & !< The background diffusion related interface viscosities [H Z T-1 ~> m2 s-1 or Pa s] dRho_int, & !< Locally referenced potential density difference across interfaces [R ~> kg m-3] - KT_extra, & !< Double diffusion diffusivity of temperature [Z2 T-1 ~> m2 s-1] - KS_extra !< Double diffusion diffusivity of salinity [Z2 T-1 ~> m2 s-1] + KT_extra, & !< Double diffusion diffusivity of temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra !< Double diffusion diffusivity of salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: dissip ! local variable for dissipation calculations [Z2 R T-3 ~> W m-3] real :: Omega2 ! squared absolute rotation rate [T-2 ~> s-2] @@ -310,7 +314,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i Kd_int(:,:,:) = CS%Kd if (present(Kd_extra_T)) Kd_extra_T(:,:,:) = 0.0 if (present(Kd_extra_S)) Kd_extra_S(:,:,:) = 0.0 - if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = GV%Z_to_H*CS%Kv + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv ! Set up arrays for diagnostics. @@ -408,7 +412,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay_2d, Kd_int_2d, Kv_bkgnd, j, G, GV, US, CS%bkgnd_mixing_csp) ! Update Kv and 3-d diffusivity diagnostics. if (associated(visc%Kv_slow)) then ; do K=1,nz+1 ; do i=is,ie - visc%Kv_slow(i,j,K) = visc%Kv_slow(i,j,K) + GV%Z_to_H*Kv_bkgnd(i,K) + visc%Kv_slow(i,j,K) = visc%Kv_slow(i,j,K) + Kv_bkgnd(i,K) enddo ; enddo ; endif if (CS%id_Kv_bkgnd > 0) then ; do K=1,nz+1 ; do i=is,ie dd%Kv_bkgnd(i,j,K) = Kv_bkgnd(i,K) @@ -426,12 +430,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (KS_extra(i,K) > KT_extra(i,K)) then ! salt fingering Kd_lay_2d(i,k-1) = Kd_lay_2d(i,k-1) + 0.5 * KT_extra(i,K) Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * KT_extra(i,K) - Kd_extra_S(i,j,K) = (KS_extra(i,K) - KT_extra(i,K)) + Kd_extra_S(i,j,K) = KS_extra(i,K) - KT_extra(i,K) Kd_extra_T(i,j,K) = 0.0 elseif (KT_extra(i,K) > 0.0) then ! double-diffusive convection Kd_lay_2d(i,k-1) = Kd_lay_2d(i,k-1) + 0.5 * KS_extra(i,K) Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * KS_extra(i,K) - Kd_extra_T(i,j,K) = (KT_extra(i,K) - KS_extra(i,K)) + Kd_extra_T(i,j,K) = KT_extra(i,K) - KS_extra(i,K) Kd_extra_S(i,j,K) = 0.0 else ! There is no double diffusion at this interface. Kd_extra_T(i,j,K) = 0.0 @@ -474,14 +478,14 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! Add the input turbulent diffusivity. if (CS%useKappaShear .or. CS%use_CVMix_shear) then do K=2,nz ; do i=is,ie - Kd_int_2d(i,K) = GV%H_to_Z*visc%Kd_shear(i,j,K) + 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) + Kd_int_2d(i,K) = visc%Kd_shear(i,j,K) + 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) enddo ; enddo do i=is,ie - Kd_int_2d(i,1) = GV%H_to_Z*visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. + Kd_int_2d(i,1) = visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. Kd_int_2d(i,nz+1) = 0.0 enddo do k=1,nz ; do i=is,ie - Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + GV%H_to_Z*0.5 * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) + Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) enddo ; enddo else do i=is,ie @@ -502,7 +506,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i maxTKE, G, GV, US, CS%tidal_mixing, & CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d) - ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then @@ -525,7 +528,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_int(i,K)), & ! Floor aka Gargett CS%dissip_N2 * N2_int(i,K)) ! Floor of Kd_min*rho0/F_Ri Kd_int_2d(i,K) = max(Kd_int_2d(i,K) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_int(i,K) + Omega2)))) + dissip * (CS%FluxRi_max / (GV%H_to_RZ * (N2_int(i,K) + Omega2)))) enddo ; enddo endif @@ -550,14 +553,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_lay(i,k)), & ! Floor aka Gargett CS%dissip_N2 * N2_lay(i,k)) ! Floor of Kd_min*rho0/F_Ri Kd_lay_2d(i,k) = max(Kd_lay_2d(i,k) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2)))) + dissip * (CS%FluxRi_max / (GV%H_to_RZ * (N2_lay(i,k) + Omega2)))) enddo ; enddo endif if (associated(dd%Kd_work)) then do k=1,nz ; do i=is,ie - dd%Kd_Work(i,j,k) = GV%Rho0 * Kd_lay_2d(i,k) * N2_lay(i,k) * & - GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 + dd%Kd_Work(i,j,k) = GV%H_to_RZ * Kd_lay_2d(i,k) * N2_lay(i,k) * GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 enddo ; enddo endif @@ -580,13 +582,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif if (CS%debug) then - if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) if (CS%use_CVMix_ddiff) then - call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) then @@ -602,7 +604,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) then - call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, symmetric=.true., scale=US%Z_to_m*US%s_to_T) + call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, symmetric=.true., scale=GV%H_to_m*US%s_to_T) endif endif @@ -673,7 +675,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & !! TKE dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] integer, dimension(SZI_(G)), intent(out) :: kb !< Index of lightest layer denser than the buffer @@ -735,7 +737,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & else; TKE_to_Kd(i,k) = 0.; endif ! The maximum TKE conversion we allow is really a statement ! about the upper diffusivity we allow. Kd_max must be set. - maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of Z3 T-3. + maxTKE(i,k) = hN2pO2 * GV%H_to_Z*CS%Kd_max ! Units of Z3 T-3. enddo ; enddo kb(is:ie) = -1 ! kb should not be used by any code in non-layered mode -AJA return @@ -1055,10 +1057,10 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: Kd_T_dd !< Interface double diffusion diapycnal - !! diffusivity for temp [Z2 T-1 ~> m2 s-1]. + !! diffusivity for temp [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal - !! diffusivity for saln [Z2 T-1 ~> m2 s-1]. + !! diffusivity for saln [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G)) :: & dRho_dT, & ! partial derivatives of density with respect to temperature [R C-1 ~> kg m-3 degC-1] @@ -1072,7 +1074,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real :: Rrho ! vertical density ratio [nondim] real :: diff_dd ! factor for double-diffusion [nondim] - real :: Kd_dd ! The dominant double diffusive diffusivity [Z2 T-1 ~> m2 s-1] + real :: Kd_dd ! The dominant double diffusive diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: prandtl ! flux ratio for diffusive convection regime [nondim] real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] @@ -1124,8 +1126,8 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) end subroutine double_diffusion !> This routine adds diffusion sustained by flow energy extracted by bottom drag. -subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & - maxTKE, kb, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) +subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, & + kb, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) 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 @@ -1142,20 +1144,21 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & !! boundary layer properties and related fields integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE - !! TKE dissipated within a layer and the + !! TKE dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain !! to its maximum-realizable thickness [Z3 T-3 ~> m3 s-3] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers, - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! This routine adds diffusion sustained by flow energy extracted by bottom drag. @@ -1181,7 +1184,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] real :: R0_g ! Rho0 / G_Earth [R T2 Z-1 ~> kg s2 m-4] real :: I_rho0 ! 1 / RHO0 [R-1 ~> m3 kg-1] - real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [Z2 T-1 ~> m2 s-1]. + real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this ! extracted energy also drives diapycnal mixing. @@ -1297,13 +1300,13 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & TKE(i) = TKE(i) - TKE_to_layer - if (Kd_lay(i,k) < (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then - delta_Kd = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,k) + if (Kd_lay(i,k) < GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then + delta_Kd = GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,k) if ((CS%Kd_max >= 0.0) .and. (delta_Kd > CS%Kd_max)) then delta_Kd = CS%Kd_max Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd else - Kd_lay(i,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) + Kd_lay(i,k) = GV%Z_to_H*(TKE_to_layer + TKE_Ray) *TKE_to_Kd(i,k) endif Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * delta_Kd @@ -1313,12 +1316,12 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & endif endif else - if (Kd_lay(i,k) >= maxTKE(i,k) * TKE_to_Kd(i,k)) then + if (Kd_lay(i,k) >= GV%Z_to_H*maxTKE(i,k) * TKE_to_Kd(i,k)) then TKE_here = 0.0 TKE(i) = TKE(i) + TKE_Ray - elseif (Kd_lay(i,k) + (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & - maxTKE(i,k) * TKE_to_Kd(i,k)) then - TKE_here = ((TKE_to_layer + TKE_Ray) + Kd_lay(i,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) + elseif (Kd_lay(i,k) + GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & + GV%Z_to_H*maxTKE(i,k) * TKE_to_Kd(i,k)) then + TKE_here = ((TKE_to_layer + TKE_Ray) + GV%H_to_Z*Kd_lay(i,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) TKE(i) = (TKE(i) - TKE_here) + TKE_Ray else TKE_here = TKE_to_layer + TKE_Ray @@ -1327,7 +1330,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & if (TKE(i) < 0.0) TKE(i) = 0.0 ! This should be unnecessary? if (TKE_here > 0.0) then - delta_Kd = TKE_here * TKE_to_Kd(i,k) + delta_Kd = GV%Z_to_H*TKE_here * TKE_to_Kd(i,k) if (CS%Kd_max >= 0.0) delta_Kd = min(delta_Kd, CS%Kd_max) Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd @@ -1377,11 +1380,11 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] real, dimension(SZI_(G),SZK_(GV)+1), & - intent(inout) :: Kd_int !< Interface net diffusivity [Z2 T-1 ~> m2 s-1] + intent(inout) :: Kd_int !< Interface net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1] + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 T-1 ~> m2 s-1] + optional, intent(inout) :: Kd_lay !< Layer net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables real :: TKE_column ! net TKE input into the column [Z3 T-3 ~> m3 s-3] @@ -1397,8 +1400,8 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real :: D_minus_z ! distance to interface k from surface [Z ~> m]. real :: total_thickness ! total thickness of water column [Z ~> m]. real :: Idecay ! inverse of decay scale used for "Joule heating" loss of TKE with height [Z-1 ~> m-1]. - real :: Kd_wall ! Law of the wall diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Kd_lower ! diffusivity for lower interface [Z2 T-1 ~> m2 s-1] + real :: Kd_wall ! Law of the wall diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_lower ! diffusivity for lower interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. real :: I_Rho0 ! 1 / rho0 [R-1 ~> m3 kg-1] real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] @@ -1481,13 +1484,13 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int if ( ustar_D + absf * ( z_bot * D_minus_z ) == 0.) then Kd_wall = 0. else - Kd_wall = ((CS%von_karm * ustar2) * (z_bot * D_minus_z)) & + Kd_wall = ((GV%Z_to_H*CS%von_karm * ustar2) * (z_bot * D_minus_z)) & / (ustar_D + absf * (z_bot * D_minus_z)) endif ! TKE associated with Kd_wall [Z3 T-3 ~> m3 s-3]. ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + TKE_Kd_wall = GV%H_to_Z*Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. if (TKE_Kd_wall > 0.) then @@ -1526,27 +1529,30 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, type(forcing), intent(in) :: fluxes !< Surface fluxes structure integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This routine adds effects of mixed layer radiation to the layer diffusivities. real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [Z3 T-3 ~> m3 s-3] real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. - real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation + ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: f_sq ! The square of the local Coriolis parameter or a related variable [T-2 ~> s-2]. real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2]. real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] - real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation [Z2 T-1 ~> m2 s-1]. + real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation + ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: C1_6 ! 1/6 [nondim] real :: Omega2 ! rotation rate squared [T-2 ~> s-2]. real :: z1 ! layer thickness times I_decay [nondim] @@ -1595,9 +1601,9 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! a more accurate Taylor series approximations for very thin layers. z1 = (GV%H_to_Z*h(i,j,kml+1)) * I_decay(i) if (z1 > 1e-5) then - Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) + Kd_mlr = GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) else - Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) + Kd_mlr = GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) endif Kd_mlr_ml(i) = min(Kd_mlr, CS%ML_rad_kd_max) TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) @@ -1624,17 +1630,17 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! This is supposed to be the integrated energy deposited in the layer, ! not the average over the layer as in these expressions. if (z1 > 1e-5) then - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 + Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * ((1.0 - exp(-z1)) / dzL) ! Units of m-1 else - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 + Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 endif else if (z1 > 1e-5) then - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (1.0 - exp(-z1)) + Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (1.0 - exp(-z1)) else - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) + Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) endif endif Kd_mlr = min(Kd_mlr, CS%ML_rad_kd_max) @@ -1645,7 +1651,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * Kd_mlr TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) - if (TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then + if (GV%Z_to_H*TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then do_i(i) = .false. else ; do_any = .true. ; endif endif ; enddo @@ -1995,6 +2001,8 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ # include "version_variable.h" character(len=40) :: mdl = "MOM_set_diffusivity" ! This module's name. real :: vonKar ! The von Karman constant as used for mixed layer viscosity [nondim] + real :: Kd_z ! The background diapycnal diffusivity in [Z2 T-1 ~> m2 s-1] for use + ! in setting the default for other diffusivities. real :: omega_frac_dflt ! The default value for the fraction of the absolute rotation rate ! that is used in place of the absolute value of the local Coriolis ! parameter in the denominator of some expressions [nondim] @@ -2085,7 +2093,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The maximum diapycnal diffusivity due to turbulence "//& "radiated from the base of the mixed layer. "//& "This is only used if ML_RADIATION is true.", & - units="m2 s-1", default=1.0e-3, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-3, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "ML_RAD_COEFF", CS%ML_rad_coeff, & "The coefficient which scales MSTAR*USTAR^3 to obtain "//& "the energy available for mixing below the base of the "//& @@ -2163,7 +2171,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL endif CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & - 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) @@ -2180,19 +2188,20 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KV", CS%Kv, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + units="m2 s-1", scale=GV%m2_s_to_HZ_T, fail_if_missing=.true.) - call get_param(param_file, mdl, "KD", CS%Kd, & + call get_param(param_file, mdl, "KD", Kd_z, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + CS%Kd = (GV%m2_s_to_HZ_T*US%Z2_T_to_m2_s) * Kd_z call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & "The maximum permitted increment for the diapycnal "//& "diffusivity from TKE-based parameterizations, or a negative "//& - "value for no limit.", units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T) + "value for no limit.", units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T) if (CS%simple_TKE_to_Kd) then if (CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: To use SIMPLE_TKE_TO_KD, KD_MAX must be set to >0.") @@ -2205,7 +2214,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD_ADD", CS%Kd_add, & "A uniform diapycnal diffusivity that is added "//& "everywhere without any filtering or scaling.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T) if (CS%use_LOTW_BBL_diffusivity .and. CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: KD_MAX must be set (positive) when "// & "USE_LOTW_BBL_DIFFUSIVITY=True.") @@ -2237,21 +2246,21 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ units="J m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m*US%s_to_T) call get_param(param_file, mdl, "DISSIPATION_KD_MIN", CS%dissip_Kd_min, & "The minimum vertical diffusivity applied as a floor.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T) CS%limit_dissipation = (CS%dissip_min>0.) .or. (CS%dissip_N1>0.) .or. & (CS%dissip_N0>0.) .or. (CS%dissip_Kd_min>0.) CS%dissip_N2 = 0.0 if (CS%FluxRi_max > 0.0) & - CS%dissip_N2 = CS%dissip_Kd_min * GV%Rho0 / CS%FluxRi_max + CS%dissip_N2 = CS%dissip_Kd_min * GV%H_to_RZ / CS%FluxRi_max CS%id_Kd_bkgnd = register_diag_field('ocean_model', 'Kd_bkgnd', diag%axesTi, Time, & - 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_Kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & - 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & - 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_tidal_mixing) then CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & @@ -2259,7 +2268,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & 'Maximum layer TKE', 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & - 'Convert TKE to Kd', 's2 m', conversion=US%Z2_T_to_m2_s*(US%m_to_Z**3*US%T_to_s**3)) + 'Convert TKE to Kd', 's2 m', conversion=GV%HZ_T_to_m2_s*(GV%m_to_H*US%m_to_Z**2*US%T_to_s**3)) CS%id_N2 = register_diag_field('ocean_model', 'N2', diag%axesTi, Time, & 'Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2, cmor_field_name='obvfsq', & cmor_long_name='Square of seawater buoyancy frequency', & @@ -2268,7 +2277,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ if (CS%user_change_diff) & CS%id_Kd_user = register_diag_field('ocean_model', 'Kd_user', diag%axesTi, Time, & - 'User-specified Extra Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'User-specified Extra Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, & "If true, increase diffusivites for temperature or salinity based on the "//& @@ -2281,10 +2290,10 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ default=2.55, units="nondim") call get_param(param_file, mdl, "MAX_SALT_DIFF_SALT_FINGERS", CS%Max_salt_diff_salt_fingers, & "Maximum salt diffusivity for salt fingering regime.", & - default=1.e-4, units="m2 s-1", scale=US%m2_s_to_Z2_T) + default=1.e-4, units="m2 s-1", scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & "Molecular viscosity for calculation of fluxes under double-diffusive "//& - "convection.", default=1.5e-6, units="m2 s-1", scale=US%m2_s_to_Z2_T) + "convection.", default=1.5e-6, units="m2 s-1", scale=GV%m2_s_to_HZ_T) ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. endif ! old double-diffusion @@ -2322,9 +2331,9 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ if (CS%double_diffusion .or. CS%use_CVMix_ddiff) then CS%id_KT_extra = register_diag_field('ocean_model', 'KT_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_KS_extra = register_diag_field('ocean_model', 'KS_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif if (CS%use_CVMix_ddiff) then CS%id_R_rho = register_diag_field('ocean_model', 'R_rho', diag%axesTi, Time, & diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 57fc98834e..33e7a6ddf8 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -43,9 +43,11 @@ module MOM_tidal_mixing !> Containers for tidal mixing diagnostics type, public :: tidal_mixing_diags ; private - real, allocatable :: Kd_itidal(:,:,:) !< internal tide diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. - real, allocatable :: Fl_itidal(:,:,:) !< vertical flux of tidal turbulent dissipation [Z3 T-3 ~> m3 s-3] - real, allocatable :: Kd_Niku(:,:,:) !< lee-wave diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. + real, allocatable :: Kd_itidal(:,:,:) !< internal tide diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, allocatable :: Fl_itidal(:,:,:) !< vertical flux of tidal turbulent dissipation + !! [Z3 T-3 ~> m3 s-3] + real, allocatable :: Kd_Niku(:,:,:) !< lee-wave diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Kd_Niku_work(:,:,:) !< layer integrated work by lee-wave driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Itidal_Work(:,:,:) !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Lowmode_Work(:,:,:) !< layer integrated work by low mode driven mixing [R Z3 T-3 ~> W m-2] @@ -55,14 +57,14 @@ module MOM_tidal_mixing real, allocatable :: tidal_qe_md(:,:,:) !< Input tidal energy dissipated locally, !! interpolated to model vertical coordinate [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_lowmode(:,:,:) !< internal tide diffusivity at interfaces - !! due to propagating low modes [Z2 T-1 ~> m2 s-1]. + !! due to propagating low modes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Fl_lowmode(:,:,:) !< vertical flux of tidal turbulent !! dissipation due to propagating low modes [Z3 T-3 ~> m3 s-3] real, allocatable :: TKE_itidal_used(:,:) !< internal tide TKE input at ocean bottom [R Z3 T-3 ~> W m-2] real, allocatable :: N2_bot(:,:) !< bottom squared buoyancy frequency [T-2 ~> s-2] real, allocatable :: N2_meanz(:,:) !< vertically averaged buoyancy frequency [T-2 ~> s-2] - real, allocatable :: Polzin_decay_scale_scaled(:,:) !< vertical scale of decay for tidal dissipation [Z ~> m] - real, allocatable :: Polzin_decay_scale(:,:) !< vertical decay scale for tidal dissipation with Polzin [Z ~> m] + real, allocatable :: Polzin_decay_scale_scaled(:,:) !< Vertical scale of decay for tidal dissipation [Z ~> m] + real, allocatable :: Polzin_decay_scale(:,:) !< Vertical decay scale for tidal dissipation with Polzin [Z ~> m] real, allocatable :: Simmons_coeff_2d(:,:) !< The Simmons et al mixing coefficient [nondim] end type @@ -86,7 +88,7 @@ module MOM_tidal_mixing !! for dissipation of the lee waves. Schemes that are !! currently encoded are St Laurent et al (2002) and !! Polzin (2009). - real :: Int_tide_decay_scale !< decay scale for internal wave TKE [Z ~> m]. + real :: Int_tide_decay_scale !< decay scale for internal wave TKE [Z ~> m] real :: Mu_itides !< efficiency for conversion of dissipation !! to potential energy [nondim] @@ -117,7 +119,7 @@ module MOM_tidal_mixing !! profile in Polzin formulation should not exceed !! Polzin_decay_scale_max_factor * depth of the ocean [nondim]. real :: Polzin_min_decay_scale !< minimum decay scale of the tidal dissipation - !! profile in Polzin formulation [Z ~> m]. + !! profile in Polzin formulation [Z ~> m] real :: TKE_itide_max !< maximum internal tide conversion [R Z3 T-3 ~> W m-2] !! available to mix above the BBL @@ -639,7 +641,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%Lowmode_itidal_dissipation) then CS%id_Kd_itidal = register_diag_field('ocean_model','Kd_itides',diag%axesTi,Time, & - 'Internal Tide Driven Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Internal Tide Driven Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_CVMix_tidal) then CS%id_N2_int = register_diag_field('ocean_model','N2_int',diag%axesTi,Time, & @@ -666,7 +668,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%id_Kd_lowmode = register_diag_field('ocean_model','Kd_lowmode',diag%axesTi,Time, & 'Internal Tide Driven Diffusivity (from propagating low modes)', & - 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_Fl_itidal = register_diag_field('ocean_model','Fl_itides',diag%axesTi,Time, & 'Vertical flux of tidal turbulent dissipation', & @@ -708,7 +710,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di 'Lee wave Driven Turbulent Kinetic Energy', & 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Kd_Niku = register_diag_field('ocean_model','Kd_Nikurashin',diag%axesTi,Time, & - 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif endif ! S%use_CVMix_tidal endif @@ -737,21 +739,22 @@ subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_T !! dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !! Set this to a negative value to have no limit. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then @@ -779,9 +782,11 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & - optional, intent(inout) :: Kd_int!< The diapycnal diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_int!< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! Local variables real, dimension(SZK_(GV)+1) :: Kd_tidal ! tidal diffusivity [m2 s-1] real, dimension(SZK_(GV)+1) :: Kv_tidal ! tidal viscosity [m2 s-1] @@ -801,7 +806,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! related to the distribution of tidal mixing energy, with unusual array ! extents that are not explained, that is set and used by the CVMix ! tidal mixing schemes, perhaps in [m3 kg-1]? - real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] real :: Simmons_coeff ! A coefficient in the Simmons et al (2004) mixing parameterization [nondim] integer :: i, k, is, ie @@ -862,12 +867,12 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update diffusivity if (present(Kd_lay)) then do k=1,GV%ke - Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo endif if (present(Kd_int)) then do K=1,GV%ke+1 - Kd_int(i,K) = Kd_int(i,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) + Kd_int(i,K) = Kd_int(i,K) + GV%m2_s_to_HZ_T * Kd_tidal(K) enddo endif ! Update viscosity with the proper unit conversion. @@ -879,7 +884,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! diagnostics if (allocated(CS%dd%Kd_itidal)) then - CS%dd%Kd_itidal(i,j,:) = US%m2_s_to_Z2_T * Kd_tidal(:) + CS%dd%Kd_itidal(i,j,:) = GV%m2_s_to_HZ_T * Kd_tidal(:) endif if (allocated(CS%dd%N2_int)) then CS%dd%N2_int(i,j,:) = N2_int(i,:) @@ -963,12 +968,12 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update diffusivity if (present(Kd_lay)) then do k=1,GV%ke - Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo endif if (present(Kd_int)) then do K=1,GV%ke+1 - Kd_int(i,K) = Kd_int(i,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) + Kd_int(i,K) = Kd_int(i,K) + (GV%m2_s_to_HZ_T * Kd_tidal(K)) enddo endif @@ -981,7 +986,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! diagnostics if (allocated(CS%dd%Kd_itidal)) then - CS%dd%Kd_itidal(i,j,:) = US%m2_s_to_Z2_T*Kd_tidal(:) + CS%dd%Kd_itidal(i,j,:) = GV%m2_s_to_HZ_T*Kd_tidal(:) endif if (allocated(CS%dd%N2_int)) then CS%dd%N2_int(i,j,:) = N2_int(i,:) @@ -1029,19 +1034,20 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & !! dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. !! Set this to a negative value to have no limit. real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1] + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! local @@ -1054,7 +1060,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [Z3 T-3 ~> m3 s-3] (BDM) Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] - Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] (BDM) + Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m]. z0_Polzin_scaled, & ! TKE decay scale in Polzin formulation [Z ~> m]. ! multiplied by N2_bot/N2_meanz to be coherent with the WKB scaled z @@ -1067,15 +1073,15 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_frac_top, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lowmode, & - ! fraction of bottom TKE that should appear at top of a layer [nondim] (BDM) + ! fraction of bottom TKE that should appear at top of a layer [nondim] z_from_bot, & ! distance from bottom [Z ~> m]. z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m]. real :: I_rho0 ! Inverse of the Boussinesq reference density, i.e. 1 / RHO0 [R-1 ~> m3 kg-1] - real :: Kd_add ! diffusivity to add in a layer [Z2 T-1 ~> m2 s-1]. + real :: Kd_add ! Diffusivity to add in a layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [Z3 T-3 ~> m3 s-3] real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [Z3 T-3 ~> m3 s-3] - real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [Z3 T-3 ~> m3 s-3] (BDM) + real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [Z3 T-3 ~> m3 s-3] real :: frac_used ! fraction of TKE that can be used in a layer [nondim] real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1]. real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1]. @@ -1309,7 +1315,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*(TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (present(Kd_lay)) then @@ -1325,7 +1331,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%Kd_itidal)) then ! If at layers, CS%dd%Kd_itidal is just TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (present(Kd_lay)) then @@ -1423,7 +1429,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%Kd_itidal)) then ! If at layers, this is just CS%dd%Kd_itidal(i,j,K) = TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k Control structure for user_change_diffusivity type, public :: user_change_diff_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: Kd_add !< The scale of a diffusivity that is added everywhere - !! without any filtering or scaling [Z2 T-1 ~> m2 s-1]. + real :: Kd_add !< The scale of a diffusivity that is added everywhere without + !! any filtering or scaling [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: lat_range(4) !< 4 values that define the latitude range over which !! a diffusivity scaled by Kd_add is added [degrees_N]. real :: rho_range(4) !< 4 values that define the coordinate potential @@ -54,17 +54,17 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i !! fields. Absent fields have NULL ptrs. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(user_change_diff_CS), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of - !! each layer [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity - !! at each interface [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of each + !! layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at each + !! interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: T_f !< Temperature with massless !! layers filled in vertically [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: S_f !< Salinity with massless !! layers filled in vertically [S ~> ppt]. real, dimension(:,:,:), optional, pointer :: Kd_int_add !< The diapycnal !! diffusivity that is being added at - !! each interface [Z2 T-1 ~> m2 s-1]. + !! each interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables real :: Rcv(SZI_(G),SZK_(GV)) ! The coordinate density in layers [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures [R L2 T-2 ~> Pa]. @@ -222,7 +222,7 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USER_KD_ADD", CS%Kd_add, & "A user-specified additional diffusivity over a range of "//& - "latitude and density.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + "latitude and density.", default=0.0, units="m2 s-1", scale=GV%m2_s_to_HZ_T) if (CS%Kd_add /= 0.0) then call get_param(param_file, mdl, "USER_KD_ADD_LAT_RANGE", CS%lat_range(:), & "Four successive values that define a range of latitudes "//& From 359bdcbc833565bcd61a0819427f9b5a6caaabfe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 18 Jul 2023 22:01:37 -0400 Subject: [PATCH 030/146] +*Use [H Z2 T-3 ~> m3 s-3 or W m-2] for TKE units Changed the units for TKE arguments to [H Z2 T-3 ~> m3 s-3 or W m-2] for find_TKE_to_Kd, add_drag_diffusivity, calculate_tidal_mixing and add_int_tide_diffusivity, with similar changes to the units of 21 diagnostics or internal variables in the same routines and in add_LOTW_BBL_diffusivity and add_MLrad_diffusivity. Dozens of unit conversion factors were also cancelled out with these changes, including using that GV%Z_to_H/GV%Rho_0 = GV%RZ_to_H and that GV%Rho_0*GV%H_to_Z = GV%H_to_RZ for both Boussinesq or non-Boussinesq configurations. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode unless GV%Rho_0 is chosen to be an integer power of 2. --- .../vertical/MOM_set_diffusivity.F90 | 92 +++++++++---------- .../vertical/MOM_tidal_mixing.F90 | 90 +++++++++--------- 2 files changed, 88 insertions(+), 94 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 97a34ddbcb..4fb0791b8f 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -181,7 +181,7 @@ module MOM_set_diffusivity Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] - maxTKE => NULL(), & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] + maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -254,7 +254,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i real, dimension(SZI_(G),SZK_(GV)) :: & N2_lay, & !< Squared buoyancy frequency associated with layers [T-2 ~> s-2] Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - maxTKE, & !< Energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] + maxTKE, & !< Energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer !< [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] @@ -676,8 +676,8 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain to its + !! maximum realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] integer, dimension(SZI_(G)), intent(out) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer. ! Local variables @@ -737,7 +737,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & else; TKE_to_Kd(i,k) = 0.; endif ! The maximum TKE conversion we allow is really a statement ! about the upper diffusivity we allow. Kd_max must be set. - maxTKE(i,k) = hN2pO2 * GV%H_to_Z*CS%Kd_max ! Units of Z3 T-3. + maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of H Z2 T-3. enddo ; enddo kb(is:ie) = -1 ! kb should not be used by any code in non-layered mode -AJA return @@ -856,7 +856,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & dRho_lay = 0.5 * max(dRho_int(i,K) + dRho_int(i,K+1), 0.0) maxTKE(i,k) = I_dt * (G_IRho0 * & (0.5*max(dRho_int(i,K+1) + dsp1_ds(i,k)*dRho_int(i,K), 0.0))) * & - ((GV%H_to_Z*h(i,j,k) + dh_max) * maxEnt(i,k)) + ((h(i,j,k) + GV%Z_to_H*dh_max) * maxEnt(i,k)) ! TKE_to_Kd should be rho_InSitu / G_Earth * (delta rho_InSitu) ! The omega^2 term in TKE_to_Kd is due to a rescaling of the efficiency of turbulent ! mixing by a factor of N^2 / (N^2 + Omega^2), as proposed by Melet et al., 2013? @@ -1148,8 +1148,8 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum-realizable thickness [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain to its + !! maximum-realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure @@ -1172,18 +1172,17 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, ! the local ustar, times R0_g [R Z ~> kg m-2] Rho_top, & ! density at top of the BBL [R ~> kg m-3] TKE, & ! turbulent kinetic energy available to drive - ! bottom-boundary layer mixing in a layer [Z3 T-3 ~> m3 s-3] + ! bottom-boundary layer mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] I2decay ! inverse of twice the TKE decay scale [Z-1 ~> m-1]. - real :: TKE_to_layer ! TKE used to drive mixing in a layer [Z3 T-3 ~> m3 s-3] - real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [Z3 T-3 ~> m3 s-3] - real :: TKE_here ! TKE that goes into mixing in this layer [Z3 T-3 ~> m3 s-3] + real :: TKE_to_layer ! TKE used to drive mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_here ! TKE that goes into mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: dRl, dRbot ! temporaries holding density differences [R ~> kg m-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] real :: ustar_h ! value of ustar at a thickness point [Z T-1 ~> m s-1]. real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] real :: R0_g ! Rho0 / G_Earth [R T2 Z-1 ~> kg s2 m-4] - real :: I_rho0 ! 1 / RHO0 [R-1 ~> m3 kg-1] real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this @@ -1203,7 +1202,6 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, TKE_Ray = 0.0 ; Rayleigh_drag = .false. if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0 / (GV%Rho0) R0_g = GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo @@ -1227,10 +1225,10 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, I2decay(i) = 0.5*CS%IMax_decay endif TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & - GV%H_to_Z*visc%TKE_BBL(i,j) + visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & - TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * I_Rho0 * & + TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * GV%RZ_to_H * & (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz)))) ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following @@ -1287,7 +1285,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, else ; TKE_to_layer = 0.0 ; endif ! TKE_Ray has been initialized to 0 above. - if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * GV%H_to_Z*US%L_to_Z**2 * G%IareaT(i,j) * & + if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1300,13 +1298,13 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, TKE(i) = TKE(i) - TKE_to_layer - if (Kd_lay(i,k) < GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then - delta_Kd = GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,k) + if (Kd_lay(i,k) < (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then + delta_Kd = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,k) if ((CS%Kd_max >= 0.0) .and. (delta_Kd > CS%Kd_max)) then delta_Kd = CS%Kd_max Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd else - Kd_lay(i,k) = GV%Z_to_H*(TKE_to_layer + TKE_Ray) *TKE_to_Kd(i,k) + Kd_lay(i,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) endif Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * delta_Kd @@ -1316,12 +1314,12 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, endif endif else - if (Kd_lay(i,k) >= GV%Z_to_H*maxTKE(i,k) * TKE_to_Kd(i,k)) then + if (Kd_lay(i,k) >= maxTKE(i,k) * TKE_to_Kd(i,k)) then TKE_here = 0.0 TKE(i) = TKE(i) + TKE_Ray - elseif (Kd_lay(i,k) + GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & - GV%Z_to_H*maxTKE(i,k) * TKE_to_Kd(i,k)) then - TKE_here = ((TKE_to_layer + TKE_Ray) + GV%H_to_Z*Kd_lay(i,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) + elseif (Kd_lay(i,k) + (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & + maxTKE(i,k) * TKE_to_Kd(i,k)) then + TKE_here = ((TKE_to_layer + TKE_Ray) + Kd_lay(i,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) TKE(i) = (TKE(i) - TKE_here) + TKE_Ray else TKE_here = TKE_to_layer + TKE_Ray @@ -1330,7 +1328,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, if (TKE(i) < 0.0) TKE(i) = 0.0 ! This should be unnecessary? if (TKE_here > 0.0) then - delta_Kd = GV%Z_to_H*TKE_here * TKE_to_Kd(i,k) + delta_Kd = TKE_here * TKE_to_Kd(i,k) if (CS%Kd_max >= 0.0) delta_Kd = min(delta_Kd, CS%Kd_max) Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd @@ -1387,10 +1385,10 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int optional, intent(inout) :: Kd_lay !< Layer net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables - real :: TKE_column ! net TKE input into the column [Z3 T-3 ~> m3 s-3] - real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [Z3 T-3 ~> m3 s-3] - real :: TKE_consumed ! TKE used for mixing in this layer [Z3 T-3 ~> m3 s-3] - real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [Z3 T-3 ~> m3 s-3] + real :: TKE_column ! net TKE input into the column [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_consumed ! TKE used for mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [H Z2 T-3 ~> m3 s-3 or W m-2] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] real :: ustar ! value of ustar at a thickness point [Z T-1 ~> m s-1]. real :: ustar2 ! square of ustar, for convenience [Z2 T-2 ~> m2 s-2] @@ -1403,7 +1401,6 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real :: Kd_wall ! Law of the wall diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: Kd_lower ! diffusivity for lower interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. - real :: I_Rho0 ! 1 / rho0 [R-1 ~> m3 kg-1] real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] logical :: Rayleigh_drag ! Set to true if there are Rayleigh drag velocities defined in visc, on ! the assumption that this extracted energy also drives diapycnal mixing. @@ -1419,7 +1416,6 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int ! Determine whether to add Rayleigh drag contribution to TKE Rayleigh_drag = .false. if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0 / (GV%Rho0) cdrag_sqrt = sqrt(CS%cdrag) do i=G%isc,G%iec ! Developed in single-column mode @@ -1441,14 +1437,14 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int Idecay = CS%IMax_decay if ((ustar > 0.0) .and. (absf > CS%IMax_decay * ustar)) Idecay = absf / ustar - ! Energy input at the bottom [Z3 T-3 ~> m3 s-3]. + ! Energy input at the bottom [H Z2 T-3 ~> m3 s-3 or W m-2]. ! (Note that visc%TKE_BBL is in [H Z2 T-3 ~> m3 s-3 or W m-2], set in set_BBL_TKE().) ! I am still unsure about sqrt(cdrag) in this expressions - AJA - TKE_column = cdrag_sqrt * GV%H_to_Z*visc%TKE_BBL(i,j) - ! Add in tidal dissipation energy at the bottom [Z3 T-3 ~> m3 s-3]. + TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) + ! Add in tidal dissipation energy at the bottom [H Z2 T-3 ~> m3 s-3 or W m-2]. ! Note that TKE_tidal is in [R Z3 T-3 ~> W m-2]. if (associated(fluxes%TKE_tidal)) & - TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * I_Rho0 + TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * GV%RZ_to_H TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column @@ -1466,7 +1462,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int ! Add in additional energy input from bottom-drag against slopes (sides) if (Rayleigh_drag) TKE_remaining = TKE_remaining + & - 0.5*CS%BBL_effic * GV%H_to_Z*US%L_to_Z**2 * G%IareaT(i,j) * & + 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1488,9 +1484,9 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int / (ustar_D + absf * (z_bot * D_minus_z)) endif - ! TKE associated with Kd_wall [Z3 T-3 ~> m3 s-3]. + ! TKE associated with Kd_wall [H Z2 T-3 ~> m3 s-3 or W m-2]. ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = GV%H_to_Z*Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. if (TKE_Kd_wall > 0.) then @@ -1543,7 +1539,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! This routine adds effects of mixed layer radiation to the layer diffusivities. real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. - real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [H Z2 T-3 ~> m3 s-3 or W m-2] real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -1587,7 +1583,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 - TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * (fluxes%ustar(i,j))) + TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * (GV%Z_to_H*fluxes%ustar(i,j))) I_decay_len2_TKE = CS%TKE_decay**2 * (f_sq / ustar_sq) if (CS%ML_rad_TKE_decay) & @@ -1601,9 +1597,9 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! a more accurate Taylor series approximations for very thin layers. z1 = (GV%H_to_Z*h(i,j,kml+1)) * I_decay(i) if (z1 > 1e-5) then - Kd_mlr = GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) else - Kd_mlr = GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) endif Kd_mlr_ml(i) = min(Kd_mlr, CS%ML_rad_kd_max) TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) @@ -1630,17 +1626,17 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! This is supposed to be the integrated energy deposited in the layer, ! not the average over the layer as in these expressions. if (z1 > 1e-5) then - Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * ((1.0 - exp(-z1)) / dzL) ! Units of m-1 else - Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 endif else if (z1 > 1e-5) then - Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (1.0 - exp(-z1)) + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (1.0 - exp(-z1)) else - Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) endif endif Kd_mlr = min(Kd_mlr, CS%ML_rad_kd_max) @@ -1651,7 +1647,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * Kd_mlr TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) - if (GV%Z_to_H*TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then + if (TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then do_i(i) = .false. else ; do_any = .true. ; endif endif ; enddo @@ -2266,7 +2262,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & - 'Maximum layer TKE', 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'Maximum layer TKE', 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & 'Convert TKE to Kd', 's2 m', conversion=GV%HZ_T_to_m2_s*(GV%m_to_H*US%m_to_Z**2*US%T_to_s**3)) CS%id_N2 = register_diag_field('ocean_model', 'N2', diag%axesTi, Time, & diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 33e7a6ddf8..bcbda88fec 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -46,7 +46,7 @@ module MOM_tidal_mixing real, allocatable :: Kd_itidal(:,:,:) !< internal tide diffusivity at interfaces !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Fl_itidal(:,:,:) !< vertical flux of tidal turbulent dissipation - !! [Z3 T-3 ~> m3 s-3] + !! [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable :: Kd_Niku(:,:,:) !< lee-wave diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Kd_Niku_work(:,:,:) !< layer integrated work by lee-wave driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Itidal_Work(:,:,:) !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] @@ -59,7 +59,7 @@ module MOM_tidal_mixing real, allocatable :: Kd_lowmode(:,:,:) !< internal tide diffusivity at interfaces !! due to propagating low modes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Fl_lowmode(:,:,:) !< vertical flux of tidal turbulent - !! dissipation due to propagating low modes [Z3 T-3 ~> m3 s-3] + !! dissipation due to propagating low modes [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable :: TKE_itidal_used(:,:) !< internal tide TKE input at ocean bottom [R Z3 T-3 ~> W m-2] real, allocatable :: N2_bot(:,:) !< bottom squared buoyancy frequency [T-2 ~> s-2] real, allocatable :: N2_meanz(:,:) !< vertically averaged buoyancy frequency [T-2 ~> s-2] @@ -672,11 +672,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%id_Fl_itidal = register_diag_field('ocean_model','Fl_itides',diag%axesTi,Time, & 'Vertical flux of tidal turbulent dissipation', & - 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) CS%id_Fl_lowmode = register_diag_field('ocean_model','Fl_lowmode',diag%axesTi,Time, & 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', & - 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale',diag%axesT1,Time, & 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', & @@ -740,8 +740,9 @@ subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_T !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer to + !! entrain to its maximum realizable + !! thickness [H Z2 T-3 ~> m3 s-3 or W m-2] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, @@ -1035,8 +1036,9 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer + !! to entrain to its maximum realizable + !! thickness [H Z2 T-3 ~> m3 s-3 or W m-2] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes @@ -1055,9 +1057,9 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & htot, & ! total thickness above or below a layer, or the ! integrated thickness in the BBL [Z ~> m]. htot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m]. - TKE_itidal_bot, & ! internal tide TKE at ocean bottom [Z3 T-3 ~> m3 s-3] - TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [Z3 T-3 ~> m3 s-3] - TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [Z3 T-3 ~> m3 s-3] (BDM) + TKE_itidal_bot, & ! internal tide TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [H Z2 T-3 ~> m3 s-3 or W m-2] Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] @@ -1067,9 +1069,9 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! z*=int(N2/N2_bot) * N2_bot/N2_meanz = int(N2/N2_meanz) ! z0_Polzin_scaled = z0_Polzin * N2_bot/N2_meanz N2_meanz, & ! vertically averaged squared buoyancy frequency [T-2 ~> s-2] for WKB scaling - TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) [Z3 T-3 ~> m3 s-3] - TKE_Niku_rem, & ! remaining lee-wave TKE [Z3 T-3 ~> m3 s-3] - TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) [Z3 T-3 ~> m3 s-3] (BDM) + TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_Niku_rem, & ! remaining lee-wave TKE [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_frac_top, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lowmode, & @@ -1077,18 +1079,17 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & z_from_bot, & ! distance from bottom [Z ~> m]. z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m]. - real :: I_rho0 ! Inverse of the Boussinesq reference density, i.e. 1 / RHO0 [R-1 ~> m3 kg-1] real :: Kd_add ! Diffusivity to add in a layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [Z3 T-3 ~> m3 s-3] - real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [Z3 T-3 ~> m3 s-3] - real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [Z3 T-3 ~> m3 s-3] + real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_used ! fraction of TKE that can be used in a layer [nondim] real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1]. real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1]. real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3]. real :: z0Ps_denom ! The denominator of the unlimited z0_Polzin_scaled [T-3 ~> s-3]. real :: z0_psl ! temporary variable [Z ~> m]. - real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] (BDM) + real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] logical :: use_Polzin, use_Simmons integer :: i, k, is, ie, nz @@ -1102,8 +1103,6 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) enddo ; enddo - I_Rho0 = 1.0 / (GV%Rho0) - use_Polzin = ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & (CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09)) .or. & (CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09))) @@ -1114,9 +1113,8 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! Calculate parameters for vertical structure of dissipation ! Simmons: if ( use_Simmons ) then - Izeta = 1.0 / max(CS%Int_tide_decay_scale, GV%H_subroundoff*GV%H_to_Z) - Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, & - GV%H_subroundoff*GV%H_to_Z) + Izeta = 1.0 / max(CS%Int_tide_decay_scale, GV%dz_subroundoff) + Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, GV%dz_subroundoff) do i=is,ie CS%Nb(i,j) = sqrt(N2_bot(i)) if (allocated(CS%dd%N2_bot)) & @@ -1148,7 +1146,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & N2_meanz(i) = N2_meanz(i) + N2_lay(i,k) * GV%H_to_Z * h(i,j,k) enddo ; enddo do i=is,ie - N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%H_subroundoff*GV%H_to_Z) + N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%dz_subroundoff) if (allocated(CS%dd%N2_meanz)) & CS%dd%N2_meanz(i,j) = N2_meanz(i) enddo @@ -1260,11 +1258,11 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_itidal_bot(i) = min(CS%TKE_itidal(i,j)*CS%Nb(i,j), CS%TKE_itide_max) if (allocated(CS%dd%TKE_itidal_used)) & CS%dd%TKE_itidal_used(i,j) = TKE_itidal_bot(i) - TKE_itidal_bot(i) = (I_rho0 * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) + TKE_itidal_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) ! Dissipation of locally trapped lee waves TKE_Niku_bot(i) = 0.0 if (CS%Lee_wave_dissipation) then - TKE_Niku_bot(i) = (I_rho0 * CS%Mu_itides * CS%Gamma_lee) * CS%TKE_Niku(i,j) + TKE_Niku_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_lee) * CS%TKE_Niku(i,j) endif ! Dissipation of propagating internal tide (baroclinic low modes; rays) (BDM) TKE_lowmode_tot = 0.0 @@ -1272,7 +1270,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (CS%Lowmode_itidal_dissipation) then ! get loss rate due to wave drag on low modes (already multiplied by q) call get_lowmode_loss(i,j,G,CS%int_tide_CSp,"WaveDrag",TKE_lowmode_tot) - TKE_lowmode_bot(i) = CS%Mu_itides * I_rho0 * TKE_lowmode_tot + TKE_lowmode_bot(i) = CS%Mu_itides * GV%RZ_to_H * TKE_lowmode_tot endif ! Vertical energy flux at bottom TKE_itidal_rem(i) = Inv_int(i) * TKE_itidal_bot(i) @@ -1302,7 +1300,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)* TKE_frac_top_lowmode(i) ! Actual power expended may be less than predicted if stratification is weak; adjust - if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > (max_TKE(i,k))) then + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay @@ -1315,7 +1313,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*(TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (present(Kd_lay)) then @@ -1331,38 +1329,38 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%Kd_itidal)) then ! If at layers, CS%dd%Kd_itidal is just TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*TKE_itide_lay + Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k (max_TKE(i,k))) then - frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then + frac_used = max_TKE(i,k) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay TKE_lowmode_lay = frac_used * TKE_lowmode_lay @@ -1413,7 +1411,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*(TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (present(Kd_lay)) then @@ -1429,36 +1427,36 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%Kd_itidal)) then ! If at layers, this is just CS%dd%Kd_itidal(i,j,K) = TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*TKE_itide_lay + Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k Date: Wed, 5 Jul 2023 17:36:25 -0400 Subject: [PATCH 031/146] +*Non-Boussinesq Rossby_front initialization Revised the Rossby_front initialization routines to work directly in thickness units and added completely separate algorithms to initialize the Rossby_front thicknesses and velocities consistently when the Boussinesq approximation is not being made. To accommodate this change, error handling was added to detect when the THICKNESS_CONFIG and TS_CONFIG settings are incompatible. As a part of this commit the units of the h arguments to Rossby_front_initialize_thickness and Rossby_front_initialize_temperature_salinity are changed. MAXIMUM_DEPTH is now read in and rescaled via get_param in the Rossby_front routines rather than simply being pulled from the ocean grid type. There are are also changes to the units of 13 internal variables and 14 new internal variables in the Rossby_front routines. Also pass max_depth as a new argument the internal function Hml to replace the use of G%max_depth and permit simpler changes to the units being worked with. All answers are bitwise identical in Boussinesq mode, but there are substantial changes (improvements?) in answers in non-Boussinesq mode that are now independent of the value of the Boussinesq reference density. There are changes to the units of arguments to two publicly visible routines. --- .../MOM_state_initialization.F90 | 29 ++- src/user/Rossby_front_2d_initialization.F90 | 232 ++++++++++++------ 2 files changed, 179 insertions(+), 82 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 802fd33d0f..ef85607db1 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -153,7 +153,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m] real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The layer thicknesses in geopotential (z) units [Z ~> m] character(len=200) :: inputdir ! The directory where NetCDF input files are. - character(len=200) :: config + character(len=200) :: config, h_config real :: H_rescale ! A rescaling factor for thicknesses from the representation in ! a restart file to the internal representation in this run [various units ~> 1] real :: dt ! The baroclinic dynamics timestep for this run [T ~> s]. @@ -263,7 +263,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & convert = .false. else ! Initialize thickness, h. - call get_param(PF, mdl, "THICKNESS_CONFIG", config, & + call get_param(PF, mdl, "THICKNESS_CONFIG", h_config, & "A string that determines how the initial layer "//& "thicknesses are specified for a new run: \n"//& " \t file - read interface heights from the file specified \n"//& @@ -294,7 +294,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& " \t USER - call a user modified routine.", & default="uniform", do_not_log=just_read) - select case (trim(config)) + select case (trim(h_config)) case ("file") call initialize_thickness_from_file(dz, depth_tot, G, GV, US, PF, file_has_thickness=.false., & mass_file=.false., just_read=just_read) @@ -344,12 +344,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & case ("soliton"); call soliton_initialize_thickness(dz, depth_tot, G, GV, US) case ("phillips"); call Phillips_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("rossby_front"); call Rossby_front_initialize_thickness(dz, G, GV, US, & - PF, just_read=just_read) + case ("rossby_front") + call Rossby_front_initialize_thickness(h, G, GV, US, PF, just_read=just_read) + convert = .false. ! Rossby_front initialization works directly in thickness units. case ("USER"); call user_initialize_thickness(dz, G, GV, PF, & just_read=just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& - "Unrecognized layer thickness configuration "//trim(config)) + "Unrecognized layer thickness configuration "//trim(h_config)) end select ! Initialize temperature and salinity (T and S). @@ -376,6 +377,16 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t USER - call a user modified routine.", & fail_if_missing=new_sim, do_not_log=just_read) ! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& + + ! Check for incompatible THICKNESS_CONFIG and TS_CONFIG settings + if (.not.convert) then ; select case (trim(config)) + case ("DOME2D", "ISOMIP", "adjustment2d", "baroclinic_zone", "sloshing", & + "seamount", "dumbbell", "SCM_CVMix_tests", "dense") + call MOM_error(FATAL, "TS_CONFIG = "//trim(config)//" does not work with thicknesses "//& + "that have already been converted to thickness units, as is the case with "//& + "THICKNESS_CONFIG = "//trim(h_config)//".") + end select ; endif + select case (trim(config)) case ("fit"); call initialize_temp_salt_fit(tv%T, tv%S, G, GV, US, PF, & eos, tv%P_Ref, just_read=just_read) @@ -401,8 +412,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & tv%S, dz, G, GV, US, PF, just_read=just_read) case ("dumbbell"); call dumbbell_initialize_temperature_salinity(tv%T, & tv%S, dz, G, GV, US, PF, just_read=just_read) - case ("rossby_front"); call Rossby_front_initialize_temperature_salinity ( tv%T, & - tv%S, dz, G, GV, US, PF, just_read=just_read) + case ("rossby_front") + if (convert .and. .not.just_read) call dz_to_thickness(dz, tv, h, G, GV, US) + call Rossby_front_initialize_temperature_salinity ( tv%T, tv%S, h, & + G, GV, US, PF, just_read=just_read) case ("SCM_CVMix_tests"); call SCM_CVMix_tests_TS_init(tv%T, tv%S, dz, & G, GV, US, PF, just_read=just_read) case ("dense"); call dense_water_initialize_TS(G, GV, US, PF, tv%T, tv%S, & diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 4f213d86d9..b76e69bb44 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -40,21 +40,23 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [Z ~> m] + intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing h. - integer :: i, j, k, is, ie, js, je, nz - real :: Tz ! Vertical temperature gradient [C Z-1 ~> degC m-1] - real :: Dml ! Mixed layer depth [Z ~> m] - real :: eta ! An interface height depth [Z ~> m] + ! Local variables + real :: Tz ! Vertical temperature gradient [C H-1 ~> degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: eta ! An interface height depth [H ~> m or kg m-2] real :: stretch ! A nondimensional stretching factor [nondim] - real :: h0 ! The stretched thickness per layer [Z ~> m] + real :: h0 ! The stretched thickness per layer [H ~> m or kg m-2] real :: T_range ! Range of temperatures over the vertical [C ~> degC] real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -69,40 +71,57 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. - Tz = T_range / G%max_depth - - select case ( coordinateMode(verticalCoordinate) ) - - case (REGRIDDING_LAYER, REGRIDDING_RHO) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) - stretch = ( ( G%max_depth + eta ) / G%max_depth ) - h0 = ( G%max_depth / real(nz) ) * stretch - do k = 1, nz - h(i,j,k) = h0 - enddo - enddo ; enddo - - case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) - stretch = ( ( G%max_depth + eta ) / G%max_depth ) - h0 = ( G%max_depth / real(nz) ) * stretch - do k = 1, nz - h(i,j,k) = h0 - enddo - enddo ; enddo - - case default - call MOM_error(FATAL,"Rossby_front_initialize: "// & - "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") - - end select + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_thickness: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + + Tz = T_range / max_depth + + if (GV%Boussinesq) then + select case ( coordinateMode(verticalCoordinate) ) + + case (REGRIDDING_LAYER, REGRIDDING_RHO) + ! This code is identical to the REGRIDDING_ZSTAR case but probably should not be. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + Dml = Hml( G, G%geoLatT(i,j), max_depth ) + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + stretch = ( ( max_depth + eta ) / max_depth ) + h0 = ( max_depth / real(nz) ) * stretch + do k = 1, nz + h(i,j,k) = h0 + enddo + enddo ; enddo + + case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) + do j = G%jsc,G%jec ; do i = G%isc,G%iec + Dml = Hml( G, G%geoLatT(i,j), max_depth ) + ! The free surface height is set so that the bottom pressure gradient is 0. + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + stretch = ( ( max_depth + eta ) / max_depth ) + h0 = ( max_depth / real(nz) ) * stretch + do k = 1, nz + h(i,j,k) = h0 + enddo + enddo ; enddo + + case default + call MOM_error(FATAL,"Rossby_front_initialize: "// & + "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") + + end select + else + ! In non-Boussinesq mode with a flat bottom, the only requirement for no bottom pressure + ! gradient and no abyssal flow is that all columns have the same mass. + h0 = max_depth / real(nz) + do k=1,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + h(i,j,k) = h0 + enddo ; enddo ; enddo + endif end subroutine Rossby_front_initialize_thickness @@ -114,20 +133,22 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handle logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. - - integer :: i, j, k, is, ie, js, je, nz + ! Local variables real :: T_ref ! Reference temperature within the surface layer [C ~> degC] real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] real :: T_range ! Range of temperatures over the vertical [C ~> degC] - real :: zc ! Position of the middle of the cell [Z ~> m] - real :: zi ! Bottom interface position relative to the sea surface [Z ~> m] - real :: dTdz ! Vertical temperature gradient [C Z-1 ~> degC m-1] + real :: zc ! Position of the middle of the cell [H ~> m or kg m-2] + real :: zi ! Bottom interface position relative to the sea surface [H ~> m or kg m-2] + real :: dTdz ! Vertical temperature gradient [C H-1 ~> degC m-1 or degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -135,24 +156,32 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', & + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & units='C', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range',& + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_temperature_salinity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + T(:,:,:) = 0.0 S(:,:,:) = S_ref - dTdz = T_range / G%max_depth + dTdz = T_range / max_depth + ! This sets the temperature to the value at the base of the specified mixed layer + ! depth from a horizontally uniform constant thermal stratification. do j = G%jsc,G%jec ; do i = G%isc,G%iec zi = 0. + Dml = Hml(G, G%geoLatT(i,j), max_depth) do k = 1, nz zi = zi - h(i,j,k) ! Bottom interface position zc = zi - 0.5*h(i,j,k) ! Position of middle of cell - zc = min( zc, -Hml(G, G%geoLatT(i,j)) ) ! Bound by depth of mixed layer - T(i,j,k) = T_ref + dTdz * zc ! Linear temperature profile + T(i,j,k) = T_ref + dTdz * min( zc, -Dml ) ! Linear temperature profile below the mixed layer enddo enddo ; enddo @@ -176,13 +205,24 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just !! read parameters without setting u & v. real :: T_range ! Range of temperatures over the vertical [C ~> degC] - real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f [L2 Z-1 T-1 C-1 ~> m s-1 degC-1] + real :: T_ref ! Reference temperature within the surface layer [C ~> degC] + real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] + real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f with rescaling + ! [L2 H-1 T-1 C-1 ~> m s-1 degC-1 or m4 kg-1 s-1 degC-1] + real :: Rho_T0_S0 ! The density at T=0, S=0 [R ~> kg m-3] real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] - real :: Dml ! Mixed layer depth [Z ~> m] - real :: zi, zc, zm ! Depths [Z ~> m]. + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + real :: dSpV_dT ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: T_here ! The temperature in the middle of a layer [C ~> degC] + real :: dTdz ! Vertical temperature gradient [C H-1 ~> degC m-1 or degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: zi, zc, zm ! Depths in thickness units [H ~> m or kg m-2]. real :: f ! The local Coriolis parameter [T-1 ~> s-1] + real :: I_f ! The Adcroft reciprocal of the local Coriolis parameter [T ~> s] real :: Ty ! The meridional temperature gradient [C L-1 ~> degC m-1] - real :: hAtU ! Interpolated layer thickness [Z ~> m]. + real :: hAtU ! Interpolated layer thickness in height units [H ~> m or kg m-2]. + real :: u_int ! The zonal velocity at an interface [L T-1 ~> m s=1] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz character(len=40) :: verticalCoordinate @@ -192,30 +232,73 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units='C', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "RHO_T0_S0", Rho_T0_S0, & + units="kg m-3", default=1000.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & - units='kg m-3 degC-1', default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + units="kg m-3 ppt-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt, do_not_log=.true.) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_velocity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + v(:,:,:) = 0.0 u(:,:,:) = 0.0 - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 - f = 0.5* (G%CoriolisBu(I,j) + G%CoriolisBu(I,j-1) ) - dUdT = 0.0 ; if (abs(f) > 0.0) & - dUdT = ( GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) - Dml = Hml( G, G%geoLatT(i,j) ) - Ty = dTdy( G, T_range, G%geoLatT(i,j), US ) - zi = 0. - do k = 1, nz - hAtU = 0.5*(h(i,j,k)+h(i+1,j,k)) * GV%H_to_Z - zi = zi - hAtU ! Bottom interface position - zc = zi - 0.5*hAtU ! Position of middle of cell - zm = max( zc + Dml, 0. ) ! Height above bottom of mixed layer - u(I,j,k) = dUdT * Ty * zm ! Thermal wind starting at base of ML - enddo - enddo ; enddo - + if (GV%Boussinesq) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + f = 0.5* (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + dUdT = 0.0 ; if (abs(f) > 0.0) & + dUdT = ( GV%H_to_Z*GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) + Dml = Hml( G, G%geoLatCu(I,j), max_depth ) + Ty = dTdy( G, T_range, G%geoLatCu(I,j), US ) + zi = 0. + do k = 1, nz + hAtU = 0.5 * (h(i,j,k) + h(i+1,j,k)) + zi = zi - hAtU ! Bottom interface position + zc = zi - 0.5*hAtU ! Position of middle of cell + zm = max( zc + Dml, 0. ) ! Height above bottom of mixed layer + u(I,j,k) = dUdT * Ty * zm ! Thermal wind starting at base of ML + enddo + enddo ; enddo + else + ! With an equation of state that is linear in density, the nonlinearies in + ! specific volume require that temperature be calculated for each layer. + + dTdz = T_range / max_depth + + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + f = 0.5* (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + I_f = 0.0 ; if (abs(f) > 0.0) I_f = 1.0 / f + Dml = Hml( G, G%geoLatCu(I,j), max_depth ) + Ty = dTdy( G, T_range, G%geoLatCu(I,j), US ) + zi = -max_depth + u_int = 0.0 ! The velocity at an interface + ! Work upward in non-Boussinesq mode + do k = nz, 1, -1 + hAtU = 0.5 * (h(i,j,k) + h(i+1,j,k)) + zc = zi + 0.5*hAtU ! Position of middle of cell + T_here = T_ref + dTdz * min(zc, -Dml) ! Linear temperature profile below the mixed layer + dSpV_dT = -dRho_dT / (Rho_T0_S0 + (dRho_dS * S_ref + dRho_dT * T_here) )**2 + dUdT = -( GV%H_to_RZ * GV%g_Earth * dSpV_dT ) * I_f + + ! There is thermal wind shear only within the mixed layer. + u(I,j,k) = u_int + dUdT * Ty * min(max((zi + Dml) + 0.5*hAtU, 0.0), 0.5*hAtU) + u_int = u_int + dUdT * Ty * min(max((zi + Dml) + hAtU, 0.0), hAtU) + + zi = zi + hAtU ! Update the layer top interface position + enddo + enddo ; enddo + endif end subroutine Rossby_front_initialize_velocity !> Pseudo coordinate across domain used by Hml() and dTdy() @@ -234,15 +317,16 @@ end function yPseudo !> Analytic prescription of mixed layer depth in 2d Rossby front test, -!! in the same units as G%max_depth (usually [Z ~> m]) -real function Hml( G, lat ) +!! in the same units as max_depth (usually [Z ~> m] or [H ~> m or kg m-2]) +real function Hml( G, lat, max_depth ) type(ocean_grid_type), intent(in) :: G !< Grid structure real, intent(in) :: lat !< Latitude in arbitrary units, often [km] + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m] or [H ~> m or kg m-2] ! Local - real :: dHML, HMLmean ! The range and mean of the mixed layer depths [Z ~> m] + real :: dHML, HMLmean ! The range and mean of the mixed layer depths [Z ~> m] or [H ~> m or kg m-2] - dHML = 0.5 * ( HMLmax - HMLmin ) * G%max_depth - HMLmean = 0.5 * ( HMLmin + HMLmax ) * G%max_depth + dHML = 0.5 * ( HMLmax - HMLmin ) * max_depth + HMLmean = 0.5 * ( HMLmin + HMLmax ) * max_depth Hml = HMLmean + dHML * sin( yPseudo(G, lat) ) end function Hml From 8f5465be7408746edd2920c42dd7bab4d472a801 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 30 Jul 2023 11:59:30 -0400 Subject: [PATCH 032/146] *Fix logic of an inconsistent initialization test Corrected the logic of a recently added test for inconsistently specified thickness units during the initialization of a new run to only apply to a new run. This was causing an incorrect fatal error with some restart tests. All answers are bitwise identical in cases that worked previously, but it corrects the problem with the restarted cases that had been aborted by the test that was added with the revision to the Rossby_front_2d_initialization code. --- src/initialization/MOM_state_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ef85607db1..4ccf5b8bac 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -379,7 +379,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& ! Check for incompatible THICKNESS_CONFIG and TS_CONFIG settings - if (.not.convert) then ; select case (trim(config)) + if (new_sim .and. (.not.convert)) then ; select case (trim(config)) case ("DOME2D", "ISOMIP", "adjustment2d", "baroclinic_zone", "sloshing", & "seamount", "dumbbell", "SCM_CVMix_tests", "dense") call MOM_error(FATAL, "TS_CONFIG = "//trim(config)//" does not work with thicknesses "//& From d22b667f78d1013d441737ddae4d1b58db200411 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 20 Jul 2023 07:51:29 -0400 Subject: [PATCH 033/146] +Add find_rho_bottom Added the new subroutine find_rho_bottom to return a 1-d slice of the in situ density averaged over a specified distance from the bottom when in fully non- Boussinesq mode or an array filled with the Boussinesq reference density. This new routine is not yet used with this commit, but it has been tested in another commit that will follow shortly. All answers are bitwise identical, but there is a new public interface. --- src/core/MOM_interface_heights.F90 | 132 +++++++++++++++++++++++++++++ 1 file changed, 132 insertions(+) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index dfd1048b82..1893859fe7 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -19,6 +19,7 @@ module MOM_interface_heights public find_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple public calc_derived_thermo +public find_rho_bottom !> Calculates the heights of the free surface or all interfaces from layer thicknesses. interface find_eta @@ -313,6 +314,137 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) end subroutine calc_derived_thermo + +!> Determine the in situ density averaged over a specified distance from the bottom, +!! calculating it as the inverse of the mass-weighted average specific volume. +subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Height change across layers [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(in) :: pres_int !< Pressure at each interface [R L2 T-2 ~> Pa] + real, dimension(SZI_(G)), intent(in) :: dz_avg !< The vertical distance over which to average [Z ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, intent(in) :: j !< j-index of row to work on + real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + + ! Local variables + real :: hb(SZI_(G)) ! Running sum of the thickness in the bottom boundary layer [H ~> m or kg m-2] + real :: SpV_h_bot(SZI_(G)) ! Running sum of the specific volume times thickness in the bottom + ! boundary layer [R-1 H ~> m4 kg-1 or m] + real :: dz_bbl_rem(SZI_(G)) ! Vertical extent of the boundary layer that has yet to be accounted + ! for [Z ~> m] + real :: h_bbl_frac(SZI_(G)) ! Thickness of the fractional layer that makes up the top of the + ! boundary layer [H ~> m or kg m-2] + real :: T_bbl(SZI_(G)) ! Temperature of the fractional layer that makes up the top of the + ! boundary layer [C ~> degC] + real :: S_bbl(SZI_(G)) ! Salinity of the fractional layer that makes up the top of the + ! boundary layer [S ~> ppt] + real :: P_bbl(SZI_(G)) ! Pressure the top of the boundary layer [R L2 T-2 ~> Pa] + real :: dp(SZI_(G)) ! Pressure change across the fractional layer that makes up the top + ! of the boundary layer [R L2 T-2 ~> Pa] + real :: SpV_bbl(SZI_(G)) ! In situ specific volume of the fractional layer that makes up the + ! top of the boundary layer [R-1 ~> m3 kg-1] + real :: frac_in ! The fraction of a layer that is within the bottom boundary layer [nondim] + logical :: do_i(SZI_(G)), do_any + logical :: use_EOS + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, k, is, ie, nz + + is = G%isc ; ie = G%iec ; nz = GV%ke + + use_EOS = associated(tv%T) .and. associated(tv%S) .and. associated(tv%eqn_of_state) + + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.allocated(tv%SpV_avg)) then + do i=is,ie + rho_bot(i) = GV%Rho0 + enddo + else + ! Check that SpV_avg has been set. + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_rho_bottom called in fully non-Boussinesq mode with invalid values of SpV_avg.") + + ! Set the bottom density to the inverse of the in situ specific volume averaged over the + ! specified distance, with care taken to avoid having compressibility lead to an imprint + ! of the layer thicknesses on this density. + do i=is,ie + hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 + dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) + do_i(i) = .true. + if (G%mask2dT(i,j) <= 0.0) then + ! Set acceptable values for calling the equation of state over land. + T_bbl(i) = 0.0 ; S_bbl(i) = 0.0 ; dp(i) = 0.0 ; P_bbl(i) = 0.0 + SpV_bbl(i) = 1.0 ! This value is arbitrary, provided it is non-zero. + h_bbl_frac(i) = 0.0 + do_i(i) = .false. + endif + enddo + + do k=nz,1,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + if (dz(i,k) < dz_bbl_rem(i)) then + ! This layer is fully within the averaging depth. + SpV_h_bot(i) = SpV_h_bot(i) + h(i,j,k) * tv%SpV_avg(i,j,k) + dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) + hb(i) = hb(i) + h(i,j,k) + do_any = .true. + else + if (dz(i,k) > 0.0) then + frac_in = dz_bbl_rem(i) / dz(i,k) + else + frac_in = 0.0 + endif + if (use_EOS) then + ! Store the properties of this layer to determine the average + ! specific volume of the portion that is within the BBL. + T_bbl(i) = tv%T(i,j,k) ; S_bbl(i) = tv%S(i,j,k) + dp(i) = frac_in * (GV%g_Earth*GV%H_to_RZ * h(i,j,k)) + P_bbl(i) = pres_int(i,K) + (1.0-frac_in) * (GV%g_Earth*GV%H_to_RZ * h(i,j,k)) + else + SpV_bbl(i) = tv%SpV_avg(i,j,k) + endif + h_bbl_frac(i) = frac_in * h(i,j,k) + dz_bbl_rem(i) = 0.0 + do_i(i) = .false. + endif + endif ; enddo + if (.not.do_any) exit + enddo + do i=is,ie ; if (do_i(i)) then + ! The nominal bottom boundary layer is thicker than the water column, but layer 1 is + ! already included in the averages. These values are set so that the call to find + ! the layer-average specific volume will behave sensibly. + if (use_EOS) then + T_bbl(i) = tv%T(i,j,1) ; S_bbl(i) = tv%S(i,j,1) + dp(i) = 0.0 + P_bbl(i) = pres_int(i,1) + else + SpV_bbl(i) = tv%SpV_avg(i,j,1) + endif + h_bbl_frac(i) = 0.0 + endif ; enddo + + if (use_EOS) then + ! Find the average specific volume of the fractional layer atop the BBL. + EOSdom(:) = EOS_domain(G%HI) + call average_specific_vol(T_bbl, S_bbl, P_bbl, dp, SpV_bbl, tv%eqn_of_state, EOSdom) + endif + + do i=is,ie + if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff + rho_bot(i) = G%mask2dT(i,j) * (hb(i) + h_bbl_frac(i)) / (SpV_h_bot(i) + h_bbl_frac(i)*SpV_bbl(i)) + enddo + endif + +end subroutine find_rho_bottom + + !> Converts thickness from geometric height units to thickness units, perhaps via an !! inversion of the integral of the density in pressure using variables stored in !! the thermo_var_ptrs type when in non-Boussinesq mode. From e4f76c0e2fb121e2e99538925fe5fe8dbf32b396 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 20 Jul 2023 09:31:15 -0400 Subject: [PATCH 034/146] +*Non-Boussinesq internal tide drag uses density Use the in situ near bottom density to calculate the internal tide drag, energy input and energy loss terms when in non-Boussinesq mode. This change includes the addition of an argument containing the near-bottom density to propagate_int_tide, itidal_lowmode_loss and find_N2_bottom. The recently added routine find_rho_bottom is used to calculate this near-bottom density. Several instances where the Boussinesq reference density or GV%Z_to_H were used have been eliminated from use in non-Boussinesq cases by this change, to simplify the code and reduce the dependence on the value of GV%Rho_0 in non-Boussinesq mode. This involved changing the units of 4 internal variables in find_N2_bottom to use thickness units or related units. In some places, GV%Rho0 was replaced with GV%H_to_RZ. It also includes the rescaling of a variable in int_tide_CS, and a new element with the bottom drag in the int_tide_input_type. All answers are bitwise identical in Boussinesq mode, but some solutions will change in non-Boussinesq mode with this change, and there are new arguments to publicly visible subroutines and a new element in a transparent type. --- .../lateral/MOM_internal_tides.F90 | 91 ++++++++++------- .../vertical/MOM_diabatic_driver.F90 | 2 +- .../vertical/MOM_internal_tide_input.F90 | 97 +++++++++++++------ 3 files changed, 121 insertions(+), 69 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 8c56107a4f..788e922ff2 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -78,9 +78,10 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss !< energy lost due to wave breaking [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed - !< Fixed part of the energy lost due to small-scale drag [R L-2 Z3 ~> kg m-2] here; - !! This will be multiplied by N and the squared near-bottom velocity to get - !! the energy losses in [R Z3 T-3 ~> W m-2] + !< Fixed part of the energy lost due to small-scale drag [R Z3 L-2 ~> kg m-2] here; + !! This will be multiplied by N and the squared near-bottom velocity (and by + !! the near-bottom density in non-Boussinesq mode) to get the energy losses + !! in [R Z4 H-1 L-2 ~> kg m-2 or m] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_residual_loss @@ -120,7 +121,7 @@ module MOM_internal_tides real :: cdrag !< The bottom drag coefficient [nondim]. real :: drag_min_depth !< The minimum total ocean thickness that will be used in the denominator !! of the quadratic drag terms for internal tides when - !! INTERNAL_TIDE_QUAD_DRAG is true [Z ~> m] + !! INTERNAL_TIDE_QUAD_DRAG is true [H ~> m or kg m-2] logical :: apply_background_drag !< If true, apply a drag due to background processes as a sink. logical :: apply_bottom_drag @@ -187,7 +188,7 @@ module MOM_internal_tides !> Calls subroutines in this file that are needed to refract, propagate, !! and dissipate energy density of the internal tide. -subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & +subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, dt, & G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -203,6 +204,8 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. !! In some cases the input values are used, but in !! others this is set along with the wave speeds. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Rho_bot !< Near-bottom density or the Boussinesq + !! reference density [R ~> kg m-3]. real, intent(in) :: dt !< Length of time over which to advance !! the internal tides [T ~> s]. type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure @@ -228,8 +231,8 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] - real :: I_D_here ! The inverse of the local depth [Z-1 ~> m-1] - real :: I_rho0 ! The inverse fo the Boussinesq density [R-1 ~> m3 kg-1] + real :: I_D_here ! The inverse of the local water column thickness [H-1 ~> m-1 or m2 kg-1] + real :: I_mass ! The inverse of the local water mass [R-1 Z-1 ~> m2 kg-1] real :: freq2 ! The frequency squared [T-2 ~> s-2] real :: PE_term ! total potential energy of profile [R Z ~> kg m-2] real :: KE_term ! total kinetic energy of profile [R Z ~> kg m-2] @@ -244,7 +247,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] character(len=160) :: mesg ! The text of an error message - integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle, nzm + integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) type(group_pass_type), save :: pass_test, pass_En type(time_type) :: time_end @@ -252,8 +255,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle - nzm = GV%ke - I_rho0 = 1.0 / GV%Rho0 + cn_subRO = 1e-30*US%m_s_to_L_T en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T @@ -429,11 +431,20 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo - do j=jsd,jed ; do i=isd,ied - I_D_here = 1.0 / (max(GV%H_to_Z*htot(i,j), CS%drag_min_depth)) - drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & - tot_En(i,j) * I_rho0 * I_D_here)) * I_D_here - enddo ; enddo + if (GV%Boussinesq) then + ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. + do j=jsd,jed ; do i=isd,ied + I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) + drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & + tot_En(i,j) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here + enddo ; enddo + else + do j=jsd,jed ; do i=isd,ied + I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) + drag_scale(i,j) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & + sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + tot_En(i,j) * I_mass)) + enddo ; enddo + endif do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) @@ -504,7 +515,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & ! Finally, apply loss if (CS%apply_wave_drag) then ! Calculate loss rate and apply loss over the time step - call itidal_lowmode_loss(G, US, CS, Nb, Ub, CS%En, CS%TKE_itidal_loss_fixed, & + call itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, CS%En, CS%TKE_itidal_loss_fixed, & CS%TKE_itidal_loss, dt, full_halos=.false.) endif ! Check for En<0 - for debugging, delete later @@ -782,18 +793,21 @@ end subroutine sum_En !> Calculates the energy lost from the propagating internal tide due to !! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). -subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) +subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(in) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: Nb !< Near-bottom stratification [T-1 ~> s-1]. + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(in) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%nFreq,CS%nMode), & intent(inout) :: Ub !< RMS (over one period) near-bottom horizontal !! mode velocity [L T-1 ~> m s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R L-2 Z3 ~> kg m-2] - !! (rho*kappa*h^2). + intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R Z4 H-1 L-2 ~> kg m-2 or m] + !! (rho*kappa*h^2) or (kappa*h^2). real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & intent(inout) :: En !< Energy density of the internal waves [R Z3 T-2 ~> J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & @@ -830,14 +844,18 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, enddo ! Calculate TKE loss rate; units of [R Z3 T-3 ~> W m-2] here. - TKE_loss_tot = q_itides * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + TKE_loss_tot = q_itides * GV%Z_to_H * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + else + TKE_loss_tot = q_itides * (GV%RZ_to_H * Rho_bot(i,j)) * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + endif ! Update energy remaining (this is a pseudo implicit calc) ! (E(t+1)-E(t))/dt = -TKE_loss(E(t+1)/E(t)), which goes to zero as E(t+1) goes to zero if (En_tot > 0.0) then do a=1,CS%nAngle frac_per_sector = En(i,j,a,fr,m)/En_tot - TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! Wm-2 + TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [R Z3 T-3 ~> W m-2] loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1] En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt*loss_rate) enddo @@ -2458,8 +2476,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDE_DRAG_MIN_DEPTH", CS%drag_min_depth, & "The minimum total ocean thickness that will be used in the denominator "//& "of the quadratic drag terms for internal tides.", & - units="m", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%apply_bottom_drag) - CS%drag_min_depth = MAX(CS%drag_min_depth, GV%H_subroundoff * GV%H_to_Z) + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%apply_bottom_drag) + CS%drag_min_depth = MAX(CS%drag_min_depth, GV%H_subroundoff) call get_param(param_file, mdl, "INTERNAL_TIDE_FROUDE_DRAG", CS%apply_Froude_drag, & "If true, apply wave breaking as a sink.", & default=.false.) @@ -2543,9 +2561,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) else h2(i,j) = max(h2(i,j), 0.0) endif - ! Compute the fixed part; units are [R L-2 Z3 ~> kg m-2] here - ! will be multiplied by N and the squared near-bottom velocity to get into [R Z3 T-3 ~> W m-2] - CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*GV%Rho0 * US%L_to_Z*kappa_itides * h2(i,j) + ! Compute the fixed part; units are [R Z4 H-1 L-2 ~> kg m-2 or m] here + ! will be multiplied by N and the squared near-bottom velocity (and by the + ! near-bottom density in non-Boussinesq mode) to get into [R Z3 T-3 ~> W m-2] + CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor* GV%H_to_RZ * US%L_to_Z*kappa_itides * h2(i,j) enddo ; enddo deallocate(h2) @@ -2644,16 +2663,16 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) enddo call pass_var(CS%residual,G%domain) - CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & - Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) - allocate(CS%id_cn(CS%nMode), source=-1) - do m=1,CS%nMode - write(var_name, '("cn_mode",i1)') m - write(var_descript, '("Baroclinic (eigen) speed of mode ",i1)') m - CS%id_cn(m) = register_diag_field('ocean_model',var_name, diag%axesT1, & - Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) - call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - enddo + CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & + Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) + allocate(CS%id_cn(CS%nMode), source=-1) + do m=1,CS%nMode + write(var_name, '("cn_mode",i1)') m + write(var_descript, '("Baroclinic (eigen) speed of mode ",i1)') m + CS%id_cn(m) = register_diag_field('ocean_model',var_name, diag%axesT1, & + Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + enddo ! Register maps of reflection parameters diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 631a47c259..dae52592e9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -387,7 +387,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & CS%int_tide_input_CSp) call propagate_int_tide(h, tv, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & - CS%int_tide_input%Nb, dt, G, GV, US, CS%int_tide) + CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, G, GV, US, CS%int_tide) if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 95e33929df..3da21b48fb 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -14,6 +14,7 @@ module MOM_int_tide_input use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, MOM_read_data +use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom use MOM_isopycnal_slopes, only : vert_fill_TS use MOM_time_manager, only : time_type, set_time, operator(+), operator(<=) use MOM_unit_scaling, only : unit_scale_type @@ -44,7 +45,8 @@ module MOM_int_tide_input !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable, dimension(:,:) :: TKE_itidal_coef - !< The time-invariant field that enters the TKE_itidal input calculation [R Z3 T-2 ~> J m-2]. + !< The time-invariant field that enters the TKE_itidal input calculation noting that the + !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. character(len=200) :: inputdir !< The directory for input files. logical :: int_tide_source_test !< If true, apply an arbitrary generation site @@ -70,7 +72,8 @@ module MOM_int_tide_input TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. h2, & !< The squared topographic roughness height [Z2 ~> m2]. tideamp, & !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. - Nb !< The bottom stratification [T-1 ~> s-1]. + Nb, & !< The bottom stratification [T-1 ~> s-1]. + Rho_bot !< The bottom density or the Boussinesq reference density [R ~> kg m-3]. end type int_tide_input_type contains @@ -90,9 +93,12 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) !! to the internal tide sources. real, intent(in) :: dt !< The time increment [T ~> s]. type(int_tide_input_CS), pointer :: CS !< This module's control structure. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & N2_bot ! The bottom squared buoyancy frequency [T-2 ~> s-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Rho_bot ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & T_f, S_f ! The temperature and salinity in [C ~> degC] and [S ~> ppt] with the values in @@ -121,15 +127,25 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, US, larger_h_denom=.true.) endif - call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot) + call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot, Rho_bot) avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) - itide%TKE_itidal_input(i,j) = min(CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) - enddo ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) + itide%TKE_itidal_input(i,j) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) + itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) + itide%TKE_itidal_input(i,j) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), & + CS%TKE_itide_max) + enddo ; enddo + endif if (CS%int_tide_source_test) then itide%TKE_itidal_input(:,:) = 0.0 @@ -171,7 +187,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) end subroutine set_int_tide_input !> Estimates the near-bottom buoyancy frequency (N^2). -subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) +subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bot) 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 @@ -186,55 +202,62 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy frequency at the !! ocean bottom [T-2 ~> s-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: rho_bot !< The average density near the ocean + !! bottom [R ~> kg m-3] ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & + pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. dRho_int ! The unfiltered density differences across interfaces [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Layer thicknesses in depth units [Z ~> m] real, dimension(SZI_(G)) :: & - pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. Temp_int, & ! The temperature at each interface [C ~> degC] Salin_int, & ! The salinity at each interface [S ~> ppt] drho_bot, & ! The density difference at the bottom of a layer [R ~> kg m-3] h_amp, & ! The amplitude of topographic roughness [Z ~> m]. - hb, & ! The depth below a layer [Z ~> m]. - z_from_bot, & ! The height of a layer center above the bottom [Z ~> m]. + hb, & ! The thickness of the water column below the midpoint of a layer [H ~> m or kg m-2] + z_from_bot, & ! The distance of a layer center from the bottom [Z ~> m] dRho_dT, & ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. - real :: dz_int ! The thickness associated with an interface [Z ~> m]. - real :: G_Rho0 ! The gravitation acceleration divided by the Boussinesq - ! density [Z T-2 R-1 ~> m4 s-2 kg-1]. + real :: dz_int ! The vertical extent of water associated with an interface [Z ~> m] + real :: G_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. logical :: do_i(SZI_(G)), do_any integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%Rho0 + G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%H_to_RZ EOSdom(:) = EOS_domain(G%HI) ! Find the (limited) density jump across each interface. do i=is,ie dRho_int(i,1) = 0.0 ; dRho_int(i,nz+1) = 0.0 enddo -!$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & -!$OMP h2,N2_bot,G_Rho0,EOSdom) & -!$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & -!$OMP hb,dRho_bot,z_from_bot,do_i,h_amp, & -!$OMP do_any,dz_int) & -!$OMP firstprivate(dRho_int) + + !$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & + !$OMP h2,N2_bot,rho_bot,G_Rho0,EOSdom) & + !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & + !$OMP dz,hb,dRho_bot,z_from_bot,do_i,h_amp,do_any,dz_int) & + !$OMP firstprivate(dRho_int) do j=js,je + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i,1) = fluxes%p_surf(i,j) ; enddo else - do i=is,ie ; pres(i) = 0.0 ; enddo + do i=is,ie ; pres(i,1) = 0.0 ; enddo endif do K=2,nz do i=is,ie - pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) + pres(i,K) = pres(i,K-1) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:), dRho_dS(:), & + call calculate_density_derivs(Temp_int, Salin_int, pres(:,K), dRho_dT(:), dRho_dS(:), & tv%eqn_of_state, EOSdom) do i=is,ie dRho_int(i,K) = max(dRho_dT(i)*(T_f(i,j,k) - T_f(i,j,k-1)) + & @@ -250,7 +273,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) ! Find the bottom boundary layer stratification. do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 - z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = 0.5*dz(i,nz) do_i(i) = (G%mask2dT(i,j) > 0.0) h_amp(i) = sqrt(h2(i,j)) enddo @@ -258,16 +281,16 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above - hb(i) = hb(i) + dz_int + hb(i) = hb(i) + 0.5*(h(i,j,k) + h(i,j,k-1)) dRho_bot(i) = dRho_bot(i) + dRho_int(i,K) if (z_from_bot(i) > h_amp(i)) then if (k>2) then ! Always include at least one full layer. - hb(i) = hb(i) + 0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k-2)) + hb(i) = hb(i) + 0.5*(h(i,j,k-1) + h(i,j,k-2)) dRho_bot(i) = dRho_bot(i) + dRho_int(i,K-1) endif do_i(i) = .false. @@ -283,6 +306,15 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) N2_bot(i,j) = (G_Rho0 * dRho_bot(i)) / hb(i) else ; N2_bot(i,j) = 0.0 ; endif enddo + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is,ie + rho_bot(i,j) = GV%Rho0 + enddo + else + ! Average the density over the envelope of the topography. + call find_rho_bottom(h, dz, pres, h_amp, tv, j, G, GV, US, Rho_bot(:,j)) + endif enddo end subroutine find_N2_bottom @@ -359,6 +391,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) units="m s-1", default=0.0, scale=US%m_s_to_L_T) allocate(itide%Nb(isd:ied,jsd:jed), source=0.0) + allocate(itide%Rho_bot(isd:ied,jsd:jed), source=0.0) allocate(itide%h2(isd:ied,jsd:jed), source=0.0) allocate(itide%TKE_itidal_input(isd:ied,jsd:jed), source=0.0) allocate(itide%tideamp(isd:ied,jsd:jed), source=utide) @@ -452,8 +485,8 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) if (max_frac_rough >= 0.0) & itide%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, itide%h2(i,j)) - ! Compute the fixed part of internal tidal forcing; units are [R Z3 T-2 ~> J m-2] here. - CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor*GV%Rho0*& + ! Compute the fixed part of internal tidal forcing; units are [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] here. + CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 enddo ; enddo From fd31e01633c176f5c8dcf3df69c3dd3356c900cd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 3 Jul 2023 22:58:10 -0400 Subject: [PATCH 035/146] +(*)Minimum non-Boussinesq answer date of 20230701 Set a minimum answer date of 20230701 when the model is known to be in non-Boussinesq mode, and ignore all ANSWERS_2018 flags in that same mode. This change only applies to the code called from the src directories, and not to code within or called directly from the config_src/drivers directories or from another component model like SIS2 where the information about whether the model is in non-Boussinesq mode is not available. A verticalGrid_type arguemnt was added to porous_barriers_init to support one of these changes. This commit will change answers in some non-Boussinesq configurations, but all answers in existing test cases appear to be bitwise identical. There are fewer entries logged in non-Boussinesq MOM_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 13 +++--- src/ALE/MOM_regridding.F90 | 16 ++++--- src/core/MOM.F90 | 26 ++++++++--- src/core/MOM_porous_barriers.F90 | 13 +++--- src/diagnostics/MOM_diagnostics.F90 | 13 +++--- src/framework/MOM_diag_mediator.F90 | 13 +++--- .../MOM_state_initialization.F90 | 44 +++++++++++++------ .../MOM_tracer_initialization_from_Z.F90 | 24 ++++++---- src/ocean_data_assim/MOM_oda_driver.F90 | 14 +++--- .../lateral/MOM_hor_visc.F90 | 14 +++--- .../lateral/MOM_lateral_mixing_coeffs.F90 | 13 +++--- .../lateral/MOM_thickness_diffuse.F90 | 14 +++--- .../vertical/MOM_ALE_sponge.F90 | 23 ++++++---- .../vertical/MOM_energetic_PBL.F90 | 15 ++++--- .../vertical/MOM_opacity.F90 | 15 ++++--- .../vertical/MOM_regularize_layers.F90 | 13 +++--- .../vertical/MOM_set_diffusivity.F90 | 13 +++--- .../vertical/MOM_set_viscosity.F90 | 13 +++--- .../vertical/MOM_tidal_mixing.F90 | 24 ++++++---- .../vertical/MOM_vert_friction.F90 | 14 +++--- src/tracer/MOM_neutral_diffusion.F90 | 7 +-- src/user/MOM_wave_interface.F90 | 4 +- 22 files changed, 230 insertions(+), 128 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 4641747115..2e16933525 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -233,21 +233,24 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) 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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call initialize_remapping( CS%remapCS, string, & boundary_extrapolation=remap_boundary_extrap, & diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 4cc60d16b2..5c4a76c7e5 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -277,28 +277,32 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call set_regrid_params(CS, remap_answer_date=remap_answer_date) call get_param(param_file, mdl, "REGRIDDING_ANSWER_DATE", regrid_answer_date, & "The vintage of the expressions and order of arithmetic to use for regridding. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & - default=20181231) ! ### change to default=default_answer_date) + default=20181231, do_not_log=.not.GV%Boussinesq) ! ### change to default=default_answer_date) + if (.not.GV%Boussinesq) regrid_answer_date = max(regrid_answer_date, 20230701) call set_regrid_params(CS, regrid_answer_date=regrid_answer_date) endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 5dd3f45634..2f001305d1 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2012,6 +2012,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & integer :: first_direction ! An integer that indicates which direction is to be ! updated first in directionally split parts of the ! calculation. + logical :: non_Bous ! If true, this run is fully non-Boussinesq + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq logical :: use_KPP ! If true, diabatic is using KPP vertical mixing integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations @@ -2075,6 +2078,14 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & default=.false.) endif + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + non_Bous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, "MOM", "CALC_RHO_FOR_SEA_LEVEL", CS%calc_rho_for_sea_lev, & "If true, the in-situ density is used to calculate the "//& "effective sea level that is returned to the coupler. If false, "//& @@ -2336,20 +2347,23 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & default=99991231) call get_param(param_file, "MOM", "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=non_Bous) call get_param(param_file, "MOM", "SURFACE_2018_ANSWERS", answers_2018, & "If true, use expressions for the surface properties that recover the answers "//& "from the end of 2018. Otherwise, use more appropriate expressions that differ "//& - "at roundoff for non-Boussinesq cases.", default=default_2018_answers) + "at roundoff for non-Boussinesq cases.", default=default_2018_answers, do_not_log=non_Bous) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (.not.non_Bous) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, "MOM", "SURFACE_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions for the surface properties. Values below "//& "20190101 recover the answers from the end of 2018, while higher values "//& "use updated and more robust forms of the same expressions. "//& "If both SURFACE_2018_ANSWERS and SURFACE_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=non_Bous) + if (non_Bous) CS%answer_date = 99991231 call get_param(param_file, "MOM", "USE_DIABATIC_TIME_BUG", CS%use_diabatic_time_bug, & "If true, uses the wrong calendar time for diabatic processes, as was "//& @@ -3030,7 +3044,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if (CS%use_porbar) & - call porous_barriers_init(Time, US, param_file, diag, CS%por_bar_CS) + call porous_barriers_init(Time, GV, US, param_file, diag, CS%por_bar_CS) if (CS%split) then allocate(eta(SZI_(G),SZJ_(G)), source=0.0) diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index ebe3907469..d73d96b242 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -414,12 +414,13 @@ subroutine calc_por_interface(D_min, D_max, D_avg, eta_layer, w_layer, do_next) endif end subroutine calc_por_interface -subroutine porous_barriers_init(Time, US, param_file, diag, CS) - type(porous_barrier_CS), intent(inout) :: CS !< Module control structure - type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse +subroutine porous_barriers_init(Time, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< Current model time - type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(porous_barrier_CS), intent(inout) :: CS !< Module control structure ! local variables character(len=40) :: mdl = "MOM_porous_barriers" ! This module's name. @@ -439,7 +440,9 @@ subroutine porous_barriers_init(Time, US, param_file, diag, CS) call get_param(param_file, mdl, "PORBAR_ANSWER_DATE", CS%answer_date, & "The vintage of the porous barrier weight function calculations. Values below "//& "20220806 recover the old answers in which the layer averaged weights are not "//& - "strictly limited by an upper-bound of 1.0 .", default=default_answer_date) + "strictly limited by an upper-bound of 1.0 .", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "PORBAR_MASKING_DEPTH", CS%mask_depth, & "If the effective average depth at the velocity cell is shallower than this "//& diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 157c7268bf..c23712d8e7 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1610,21 +1610,24 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, "SPLIT", split, default=.true., do_not_log=.true.) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 092b12a2d2..58511c866b 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3184,21 +3184,24 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, & 'If true, use a grid index coordinate convention for diagnostic axes. ',& default=.false.) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4ccf5b8bac..ddccf4a754 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1171,23 +1171,29 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) default=99991231, do_not_log=just_read) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read) + default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=just_read) + "forms of the same expressions.", & + default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=just_read) + "latter takes precedence.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) else remap_answer_date = 20181231 + if (.not.GV%Boussinesq) remap_answer_date = 20230701 endif if (just_read) return ! All run-time parameters have been read, so return. @@ -2592,7 +2598,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just default=99991231, do_not_log=just_read) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read) + default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) call get_param(PF, mdl, "TEMP_SALT_INIT_VERTICAL_REMAP_ONLY", pre_gridded, & "If true, initial conditions are on the model horizontal grid. " //& "Extrapolation over missing ocean values is done using an ICE-9 "//& @@ -2602,34 +2608,44 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=just_read) + "forms of the same expressions.", & + default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) ! Revise inconsistent default answer dates for remapping. default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date, do_not_log=just_read) + "latter takes precedence.", & + default=default_remap_ans_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & "If true, use the order of arithmetic for horizontal regridding that recovers "//& "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=just_read) + "forms of the same expressions.", & + default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) ! Revise inconsistent default answer dates for horizontal regridding. default_hor_reg_ans_date = default_answer_date - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + if (GV%Boussinesq) then + if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 + if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=just_read) + "latter takes precedence.", & + default=default_hor_reg_ans_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) if (.not.useALEremapping) then call get_param(PF, mdl, "ADJUST_THICKNESS", correct_thickness, & diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 64f6673371..decd197b2b 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -127,39 +127,45 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ default=99991231) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) if (useALE) then call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date) + "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & "If true, use the order of arithmetic for horizonal regridding that recovers "//& "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for horizontal regridding. default_hor_reg_ans_date = default_answer_date - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + if (GV%Boussinesq) then + if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 + if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date) + "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) if (PRESENT(homogenize)) homog=homogenize if (PRESENT(useALEremapping)) useALE=useALEremapping diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 53615b0063..fc67b20e87 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -255,20 +255,24 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) default=99991231) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(PF, mdl, "ODA_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from original version of the ODA driver. Otherwise, use updated and "//& - "more robust forms of the same expressions.", default=default_2018_answers) + "more robust forms of the same expressions.", & + default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(PF, mdl, "ODA_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions used by the ODA driver "//& "Values below 20190101 recover the answers from the end of 2018, while higher "//& "values use updated and more robust forms of the same expressions. "//& "If both ODA_2018_ANSWERS and ODA_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) inputdir = slasher(inputdir) select case(lowercase(trim(assim_method))) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 83809d39db..f9a35c1e3d 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1795,20 +1795,24 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "HOR_VISC_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for horizontal viscosity. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "HOR_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the horizontal "//& "viscosity calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& "same expressions. If both HOR_VISC_2018_ANSWERS and HOR_VISC_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index df26f3f6a4..d3ee675269 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1507,21 +1507,24 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & "The fractional tolerance for finding the wave speeds.", & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index f24f790d06..1de4c9ba6b 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2248,20 +2248,24 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "MEKE_GEOMETRIC_2018_ANSWERS", MEKE_GEOM_answers_2018, & "If true, use expressions in the MEKE_GEOMETRIC calculation that recover the "//& "answers from the original implementation. Otherwise, use expressions that "//& - "satisfy rotational symmetry.", default=default_2018_answers) + "satisfy rotational symmetry.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for MEKE_geometric. - if (MEKE_GEOM_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.MEKE_GEOM_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (MEKE_GEOM_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.MEKE_GEOM_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "MEKE_GEOMETRIC_ANSWER_DATE", CS%MEKE_GEOM_answer_date, & "The vintage of the expressions in the MEKE_GEOMETRIC calculation. "//& "Values below 20190101 recover the answers from the original implementation, "//& "while higher values use expressions that satisfy rotational symmetry. "//& "If both MEKE_GEOMETRIC_2018_ANSWERS and MEKE_GEOMETRIC_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%MEKE_GEOM_answer_date = max(CS%MEKE_GEOM_answer_date, 20230701) endif call get_param(param_file, mdl, "USE_KH_IN_MEKE", CS%Use_KH_in_MEKE, & diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 2a30f68b42..1faeed00ba 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -228,14 +228,16 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + endif if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& @@ -243,22 +245,27 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date) + "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & "If true, use the order of arithmetic for horizontal regridding that recovers "//& "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for horizontal regridding. default_hor_reg_ans_date = default_answer_date - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + if (GV%Boussinesq) then + if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 + if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + endif call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date) + "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%hor_regrid_answer_date = max(CS%hor_regrid_answer_date, 20230701) CS%time_varying_sponges = .false. CS%nz = GV%ke diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 2c2f94519a..1556955424 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2002,21 +2002,24 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "EPBL_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for horizontal viscosity. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "EPBL_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the energetic "//& "PBL calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& "same expressions. If both EPBL_2018_ANSWERS and EPBL_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) - + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "EPBL_ORIGINAL_PE_CALC", CS%orig_PE_calc, & "If true, the ePBL code uses the original form of the "//& diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index a8029d031f..ac93e54785 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -1069,22 +1069,25 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "OPTICS_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 expressions for "//& "handling the absorption of small remaining shortwave fluxes.", & - default=default_2018_answers) + default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for optics. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "OPTICS_ANSWER_DATE", optics%answer_date, & "The vintage of the order of arithmetic and expressions in the optics calculations. "//& "Values below 20190101 recover the answers from the end of 2018, while "//& "higher values use updated and more robust forms of the same expressions. "//& "If both OPTICS_2018_ANSWERS and OPTICS_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) - + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) optics%answer_date = max(optics%answer_date, 20230701) call get_param(param_file, mdl, "PEN_SW_FLUX_ABSORB", optics%PenSW_flux_absorb, & "A minimum remaining shortwave heating rate that will be simply absorbed in "//& diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 5380b4cda0..2f2c66eca7 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -762,21 +762,24 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) default=99991231, do_not_log=just_read) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read) + default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) call get_param(param_file, mdl, "REGULARIZE_LAYERS_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, do_not_log=just_read) + "same expressions.", default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REGULARIZE_LAYERS_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the regularize "//& "layers calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& "same expressions. If both REGULARIZE_LAYERS_2018_ANSWERS and "//& "REGULARIZE_LAYERS_ANSWER_DATE are specified, the latter takes precedence.", & - default=default_answer_date) + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) endif call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 4fb0791b8f..b3b49e0772 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2048,20 +2048,23 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "SET_DIFF_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "SET_DIFF_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the set diffusivity "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use updated and more robust forms of the same expressions. "//& "If both SET_DIFF_2018_ANSWERS and SET_DIFF_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) ! CS%use_tidal_mixing is set to True if an internal tidal dissipation scheme is to be used. CS%use_tidal_mixing = tidal_mixing_init(Time, G, GV, US, param_file, & diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index f7b1456d46..9ab300560b 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2050,20 +2050,23 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "SET_VISC_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "SET_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the set viscosity "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use updated and more robust forms of the same expressions. "//& "If both SET_VISC_2018_ANSWERS and SET_VISC_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_answer_date) + "the latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& "law of the form c_drag*|u|*u. The velocity magnitude "//& diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index bcbda88fec..89129ae480 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -296,37 +296,43 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "TIDAL_MIXING_2018_ANSWERS", tide_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for the tidal mixing. default_tide_ans_date = default_answer_date - if (tide_answers_2018 .and. (default_tide_ans_date >= 20190101)) default_tide_ans_date = 20181231 - if (.not.tide_answers_2018 .and. (default_tide_ans_date < 20190101)) default_tide_ans_date = 20190101 + if (GV%Boussinesq) then + if (tide_answers_2018 .and. (default_tide_ans_date >= 20190101)) default_tide_ans_date = 20181231 + if (.not.tide_answers_2018 .and. (default_tide_ans_date < 20190101)) default_tide_ans_date = 20190101 + endif call get_param(param_file, mdl, "TIDAL_MIXING_ANSWER_DATE", CS%tidal_answer_date, & "The vintage of the order of arithmetic and expressions in the tidal mixing "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use updated and more robust forms of the same expressions. "//& "If both TIDAL_MIXING_2018_ANSWERS and TIDAL_MIXING_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_tide_ans_date) + "the latter takes precedence.", default=default_tide_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%tidal_answer_date = max(CS%tidal_answer_date, 20230701) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date) + "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) if (CS%int_tide_dissipation) then diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 6af1dd78a2..133d72fa17 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2182,15 +2182,17 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "VERT_FRICTION_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the answers "//& "from the end of 2018. Otherwise, use expressions that do not use an arbitrary "//& "hard-coded maximum viscous coupling coefficient between layers.", & - default=default_2018_answers) + default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "VERT_FRICTION_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the viscous "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& @@ -2199,7 +2201,9 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "recover a form of the viscosity within the mixed layer that breaks up the "//& "magnitude of the wind stress in some non-Boussinesq cases. "//& "If both VERT_FRICTION_2018_ANSWERS and VERT_FRICTION_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 479713863f..21201db590 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -193,11 +193,11 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 @@ -207,7 +207,8 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & answer_date=CS%remap_answer_date ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 82ed753fb3..321528b739 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -319,7 +319,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) "\t >= 20230101 - More robust expressions for Update_Stokes_Drift\n"//& "\t >= 20230102 - More robust expressions for get_StokesSL_LiFoxKemper\n"//& "\t >= 20230103 - More robust expressions for ust_2_u10_coare3p5", & - default=20221231) ! In due course change the default to default=default_answer_date) + default=20221231, do_not_log=.not.GV%Boussinesq) + !### In due course change the default to default=default_answer_date) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & From 45cd5c644b6450d921b07e687e69f14f8879c0bd Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 20 Jul 2023 22:40:44 -0400 Subject: [PATCH 036/146] Move file parser inquire calls to root PE MOM_file_parser's open_param_file() contains explicit inquire() calls when assessing the correctness of opening such a file. As written, these could be called by any rank, and are not thread safe. In rare cases (usually related to testing), this would cause a race condition and raise an error. Even ignoring the errors, it is probably better if only one rank makes these calls, rather than all of them. The following patch modifies the function so that only root PE invokes inquire(). There is not much to celebrate about this patch; it does not try to clean up the intrinsic weirdness of the IO handling. But it does appear to fix some of the most apparent problems. --- src/framework/MOM_file_parser.F90 | 40 ++++++++++++++++++------------- 1 file changed, 23 insertions(+), 17 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 35d75cff7f..88fabf0c74 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -152,28 +152,34 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) ! Check that this file has not already been opened if (CS%nfiles > 0) then reopened_file = .false. - inquire(file=trim(filename), number=iounit) - if (iounit /= -1) then - do i = 1, CS%nfiles - if (CS%iounit(i) == iounit) then - call assert(trim(CS%filename(1)) == trim(filename), & - "open_param_file: internal inconsistency! "//trim(filename)// & - " is registered as open but has the wrong unit number!") - call MOM_error(WARNING, & - "open_param_file: file "//trim(filename)// & - " has already been opened. This should NOT happen!"// & - " Did you specify the same file twice in a namelist?") - reopened_file = .true. - endif ! unit numbers - enddo ! i + + if (is_root_pe()) then + inquire(file=trim(filename), number=iounit) + if (iounit /= -1) then + do i = 1, CS%nfiles + if (CS%iounit(i) == iounit) then + call assert(trim(CS%filename(1)) == trim(filename), & + "open_param_file: internal inconsistency! "//trim(filename)// & + " is registered as open but has the wrong unit number!") + call MOM_error(WARNING, & + "open_param_file: file "//trim(filename)// & + " has already been opened. This should NOT happen!"// & + " Did you specify the same file twice in a namelist?") + reopened_file = .true. + endif ! unit numbers + enddo ! i + endif endif + if (any_across_PEs(reopened_file)) return endif ! Check that the file exists to readstdlog - inquire(file=trim(filename), exist=file_exists) - if (.not.file_exists) call MOM_error(FATAL, & - "open_param_file: Input file '"// trim(filename)//"' does not exist.") + if (is_root_pe()) then + inquire(file=trim(filename), exist=file_exists) + if (.not.file_exists) call MOM_error(FATAL, & + "open_param_file: Input file '"// trim(filename)//"' does not exist.") + endif Netcdf_file = .false. if (strlen > 3) then From f01d256ccce458ce16ca31544b6726bca5645002 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 3 Aug 2023 11:22:19 -0400 Subject: [PATCH 037/146] +Non-Boussinesq revisions to wave_interface The surface gravity waves invariably work with depths in meters to match the units of the horizontal wavenumbers, even in non-Boussinesq mode, so several of the variables that are passed to or used in the MOM_wave_interface module have been revised to use units of [Z ~> m] and not [H ~> m or kg m-2]. There are changes to the names or units of a total of 8 arguments to Stokes_PGF, Update_Stokes_Drift, Get_StokesSL_LiFoxKemper, Get_SL_Average_Prof and get_Langmuir_Number, and a new argument to StokesMixing. To accommodate these changes, there are now calls to thickness_to_dz that precede the Update_Stokes_Drift or Stokes_PGF calls and a new 3d array in step_MOM. Additionally, four hard-coded dimensional constants in Stokes_PGF were given the needed scaling factors to pass dimensional consistency testing. This change also required the addition of a unit_scale_type argument to Stokes_PGF, and corresponding changes to the calls to this routine from step_MOM_dyn_split_RK2. Three comments pointing out probable bugs or instances of inaccurate algorithms were also added. Incorrect units were also fixed in the comments describing one internal variable in Update_Stokes_Drift. Also added the new runtime parameter RHO_SFC_WAVES to set the surface seawater density that is used in comparison with the typical density of air set by RHO_AIR to estimate the 10-meter wind speed from the ocean friction velocity and the COARE 3.5 stress relationships inside of get_StokesSL_LiFoxKemper() when the Li and Fox-Kemper (2017) wave model (i.e. LF17) is used. As a part of this change, there is a new verticalGrid_type argument to the internal routine set_LF17_wave_params(). By default, RHO_SFC_WAVES is set to RHO_0. Other specific changes include: - Changed the units of the publicly visible KvS element of the wave_parameters_CS from [Z2 T-1] to [H Z T-1] - Replaced the layer thickness argument (h with units of [H ~> m or kg m-2]) to Update_Stokes_Drift(), Get_SL_Average_Prof(), get_Langmuir_Number() and Stokes_PGF() with a vertical layer extent argument (dz in units of [Z ~> m]) - Add a vertical layer extent argument (dz) to StokesMixing() - Add a unit_scale_type argument to Stokes_PGF() - Multiply a hard-coded length scale in Stokes_PGF by the correct unit scaling factor and added comments to highlight these hard-coded lengths - Corrected the unit description of the DecayScale internal variable - Changed the units of 3 internal variables and added 1 new internal variable in StokesMixing - Added two new arrays to step_MOM for the layer vertical extent and friction velocity being set via thickness_to_dz and find_ustar and being passed to Update_Stokes_Drift - Added new arrays for the layer vertical extent and calls to thickness_to_dz in KPP_compute_BLD and energetic_PBL, as well as a new dz argument to ePBL_column to provide an altered argument to get_Langmuir_Number - Use find_ustar to set the friction velocity passed to Update_Stokes_Drift - Update fluxes%ustar or fluxes%tau_mag halos as necessary when the waves are in use A total of 28 unit conversion factors were eliminated with these changes. All answers are bitwise identical in Boussinesq mode, but they are changed in non-Boussinesq mode by the use of the layer specific volume to convert between thicknesses and vertical extents. The units of several arguments to publicly visible routines are altered as is a publicly visible element in wave_parameters_CS and there is a new runtime parameter that appears in some MOM_parameter_doc files. --- src/core/MOM.F90 | 26 +++- src/core/MOM_dynamics_split_RK2.F90 | 6 +- .../vertical/MOM_CVMix_KPP.F90 | 19 ++- .../vertical/MOM_energetic_PBL.F90 | 26 ++-- src/user/MOM_wave_interface.F90 | 143 ++++++++++-------- 5 files changed, 132 insertions(+), 88 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2f001305d1..9cbb744560 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -34,7 +34,7 @@ module MOM use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : read_param, get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing, mech_forcing, find_ustar use MOM_forcing_type, only : MOM_forcing_chksum, MOM_mech_forcing_chksum use MOM_get_input, only : Get_MOM_Input, directories use MOM_io, only : MOM_io_init, vardesc, var_desc @@ -91,7 +91,7 @@ module MOM use MOM_grid, only : set_first_direction, rescale_grid_bathymetry use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_hor_index, only : rotate_hor_index -use MOM_interface_heights, only : find_eta, calc_derived_thermo +use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end use MOM_interface_filter, only : interface_filter_CS use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end @@ -544,8 +544,13 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! the end of a stepping cycle (whatever that may mean). logical :: therm_reset ! If true, reset running sums of thermodynamic quantities. real :: cycle_time ! The length of the coupled time-stepping cycle [T ~> s]. + real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & + U_star ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & ssh ! sea surface height, which may be based on eta_av [Z ~> m] + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & + dz ! Vertical distance across layers [Z ~> m] real, dimension(:,:,:), pointer :: & u => NULL(), & ! u : zonal velocity component [L T-1 ~> m s-1] @@ -672,13 +677,18 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt = time_interval / real(n_max) dt_therm = dt ; ntstep = 1 + + if (CS%UseWaves .and. associated(fluxes%ustar)) & + call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass, halo=1) + if (CS%UseWaves .and. associated(fluxes%tau_mag)) & + call pass_var(fluxes%tau_mag, G%Domain, clock=id_clock_pass, halo=1) + if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf CS%tv%p_surf => NULL() if (CS%use_p_surf_in_EOS .and. associated(fluxes%p_surf)) then CS%tv%p_surf => fluxes%p_surf if (allocated(CS%tv%SpV_avg)) call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) endif - if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif if (therm_reset) then @@ -722,12 +732,16 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%UseWaves) then ! Update wave information, which is presently kept static over each call to step_mom call enable_averages(time_interval, Time_start + real_to_time(US%T_to_s*time_interval), CS%diag) - call Update_Stokes_Drift(G, GV, US, Waves, h, forces%ustar, time_interval, do_dyn) + call find_ustar(forces, CS%tv, U_star, G, GV, US, halo=1) + call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1) + call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn) call disable_averaging(CS%diag) endif else ! not do_dyn. if (CS%UseWaves) then ! Diagnostics are not enabled in this call. - call Update_Stokes_Drift(G, GV, US, Waves, h, fluxes%ustar, time_interval, do_dyn) + call find_ustar(fluxes, CS%tv, U_star, G, GV, US, halo=1) + call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1) + call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn) endif endif @@ -3261,7 +3275,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS) ! Write initial conditions if (CS%write_IC) then allocate(restart_CSp_tmp) - restart_CSP_tmp = CS%restart_CS + restart_CSp_tmp = CS%restart_CS call restart_registry_lock(restart_CSp_tmp, unlocked=.true.) allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1)) call find_eta(CS%h, CS%tv, G, GV, US, z_interface, dZref=G%Z_ref) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 5ce9ec8962..eebb7d6b8a 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -481,7 +481,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s Use_Stokes_PGF = associated(Waves) if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF if (Use_Stokes_PGF) then - call Stokes_PGF(G, GV, h, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv ! will therefore report the sum total PGF and we avoid other @@ -748,7 +749,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s Use_Stokes_PGF = associated(Waves) if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF if (Use_Stokes_PGF) then - call Stokes_PGF(G, GV, h, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) if (.not.Waves%Passive_Stokes_PGF) then do k=1,nz do j=js,je ; do I=Isq,Ieq diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 5e56098c98..d24c3e2954 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -12,6 +12,7 @@ module MOM_CVMix_KPP use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_grid, only : ocean_grid_type, isPointInCell +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -604,7 +605,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & type(ocean_grid_type), intent(in) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] @@ -863,14 +864,14 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & Kt(i,j,k) = Kt(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,1) Ks(i,j,k) = Ks(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,2) Kv(i,j,k) = Kv(i,j,k) + GV%m2_s_to_HZ_T * Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) enddo else ! KPP replaces prior diffusivity when former is non-zero do k=1, GV%ke+1 if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,1) if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,2) if (Kviscosity(k) /= 0.) Kv(i,j,k) = GV%m2_s_to_HZ_T * Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) enddo endif endif @@ -912,7 +913,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< potential/cons temp [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< Salinity [S ~> ppt] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Velocity i-component [L T-1 ~> m s-1] @@ -924,6 +925,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement factor [nondim] ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] + ! Variables for passing to CVMix routines, often in MKS units real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars in MKS units [m s-1] real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] @@ -940,7 +943,6 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: Coriolis ! Coriolis parameter at tracer points in MKS units [s-1] real :: KPP_OBL_depth ! Boundary layer depth calculated by CVMix_kpp_compute_OBL_depth in MKS units [m] - ! Variables for EOS calculations real, dimension( 3*GV%ke ) :: rho_1D ! A column of densities [R ~> kg m-3] real, dimension( 3*GV%ke ) :: pres_1D ! A column of pressures [R L2 T-2 ~> Pa] @@ -996,6 +998,9 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl GoRho = US%Z_to_m*US%s_to_T**2 * GoRho_Z_L2 buoy_scale = US%L_to_m**2*US%s_to_T**3 + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US) + ! loop over horizontal points on processor !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, vt2_1d, & @@ -1005,7 +1010,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_guess, LA, rho_1D, & !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & !$OMP z_inter, OBL_depth, BulkRi_1d, zBottomMinusOffset) & - !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & + !$OMP shared(G, GV, CS, US, uStar, h, dz, buoy_scale, buoyFlux, & !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult) do j = G%jsc, G%jec do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then @@ -1127,7 +1132,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) .and. .not. present(lamult)) then MLD_guess = max( CS%MLD_guess_min, abs(CS%OBLdepthprev(i,j) ) ) call get_Langmuir_Number(LA, G, GV, US, MLD_guess, uStar(i,j), i, j, & - H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) + dz=dz(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) CS%La_SL(i,j) = LA endif diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 1556955424..06c3915d84 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -12,6 +12,7 @@ module MOM_energetic_PBL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -309,6 +310,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & h_2d, & ! A 2-d slice of the layer thickness [H ~> m or kg m-2]. + dz_2d, & ! A 2-d slice of the vertical distance across layers [Z ~> m]. T_2d, & ! A 2-d slice of the layer temperatures [C ~> degC]. S_2d, & ! A 2-d slice of the layer salinities [S ~> ppt]. TKE_forced_2d, & ! A 2-d slice of TKE_forced [R Z3 T-2 ~> J m-2]. @@ -320,6 +322,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS Kd_2d ! A 2-d version of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. real, dimension(SZK_(GV)) :: & h, & ! The layer thickness [H ~> m or kg m-2]. + dz, & ! The vertical distance across layers [Z ~> m]. T0, & ! The initial layer temperatures [C ~> degC]. S0, & ! The initial layer salinities [S ~> ppt]. dSV_dT_1d, & ! The partial derivatives of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. @@ -362,7 +365,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Zero out diagnostics before accumulation. if (CS%TKE_diagnostics) then -!!OMP parallel do default(none) shared(is,ie,js,je,CS) + !!OMP parallel do default(none) shared(is,ie,js,je,CS) do j=js,je ; do i=is,ie CS%diag_TKE_wind(i,j) = 0.0 ; CS%diag_TKE_MKE(i,j) = 0.0 CS%diag_TKE_conv(i,j) = 0.0 ; CS%diag_TKE_forcing(i,j) = 0.0 @@ -373,8 +376,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! if (CS%id_Mixing_Length>0) CS%Mixing_Length(:,:,:) = 0.0 ! if (CS%id_Velocity_Scale>0) CS%Velocity_Scale(:,:,:) = 0.0 -!!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt, & -!!OMP CS,G,GV,US,fluxes,TKE_forced,dSV_dT,dSV_dS,Kd_int) + !!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt, & + !!OMP CS,G,GV,US,fluxes,TKE_forced,dSV_dT,dSV_dS,Kd_int) do j=js,je ! Copy the thicknesses and other fields to 2-d arrays. do k=1,nz ; do i=is,ie @@ -383,6 +386,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS TKE_forced_2d(i,k) = TKE_forced(i,j,k) dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; dSV_dS_2d(i,k) = dSV_dS(i,j,k) enddo ; enddo + call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) ! Determine the initial mech_TKE and conv_PErel, including the energy required ! to mix surface heating through the topmost cell, the energy released by mixing @@ -394,7 +398,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Copy the thicknesses and other fields to 1-d arrays. do k=1,nz - h(k) = h_2d(i,k) + GV%H_subroundoff ; u(k) = u_2d(i,k) ; v(k) = v_2d(i,k) + h(k) = h_2d(i,k) + GV%H_subroundoff ; dz(k) = dz_2d(i,k) + GV%dZ_subroundoff + u(k) = u_2d(i,k) ; v(k) = v_2d(i,k) T0(k) = T_2d(i,k) ; S0(k) = S_2d(i,k) ; TKE_forcing(k) = TKE_forced_2d(i,k) dSV_dT_1d(k) = dSV_dT_2d(i,k) ; dSV_dS_1d(k) = dSV_dS_2d(i,k) enddo @@ -421,15 +426,15 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Perhaps provide a first guess for MLD based on a stored previous value. MLD_io = -1.0 - if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) + if (CS%MLD_iteration_guess .and. (CS%ML_depth(i,j) > 0.0)) MLD_io = CS%ML_depth(i,j) if (stoch_CS%pert_epbl) then ! stochastics are active - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j, & TKE_gen_stoch=stoch_CS%epbl1_wts(i,j), TKE_diss_stoch=stoch_CS%epbl2_wts(i,j)) else - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j) endif @@ -499,12 +504,13 @@ end subroutine energetic_PBL !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model for a single column of water. -subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & +subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & Waves, G, i, j, TKE_gen_stoch, TKE_diss_stoch) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m]. real, dimension(SZK_(GV)), intent(in) :: u !< Zonal velocities interpolated to h points !! [L T-1 ~> m s-1]. real, dimension(SZK_(GV)), intent(in) :: v !< Zonal velocities interpolated to h points @@ -828,7 +834,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !/ Here we get MStar, which is the ratio of convective TKE driven mixing to UStar**3 MLD_guess_z = GV%H_to_Z*MLD_guess ! Convert MLD from thickness to height coordinates for these calls if (CS%Use_LT) then - call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess_z), u_star_mean, i, j, h, Waves, & + call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess_z), u_star_mean, i, j, dz, Waves, & U_H=u, V_H=v) call find_mstar(CS, US, B_flux, u_star, u_star_Mean, MLD_guess_z, absf, & MStar_total, Langmuir_Number=La, Convect_Langmuir_Number=LAmod,& @@ -1931,7 +1937,7 @@ subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) scale = 1.0 ; if (present(m_to_MLD_units)) scale = US%Z_to_m * m_to_MLD_units do j=G%jsc,G%jec ; do i=G%isc,G%iec - MLD(i,j) = scale*CS%ML_Depth(i,j) + MLD(i,j) = scale*CS%ML_depth(i,j) enddo ; enddo end subroutine energetic_PBL_get_MLD diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 321528b739..580e293f4f 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -97,7 +97,7 @@ module MOM_wave_interface !! Horizontal -> V points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] + KvS !< Viscosity for Stokes Drift shear [H Z T-1 ~> m2 s-1 or Pa s] ! The remainder of this control structure is private integer :: WaveMethod = -99 !< Options for including wave information @@ -197,6 +197,8 @@ module MOM_wave_interface real :: VonKar = -1.0 !< The von Karman coefficient as used in the MOM_wave_interface module [nondim] real :: rho_air !< A typical density of air at sea level, as used in wave calculations [R ~> kg m-3] real :: nu_air !< The viscosity of air, as used in wave calculations [Z2 T-1 ~> m2 s-1] + real :: rho_ocn !< A typical surface density of seawater, as used in wave calculations in + !! comparison with the density of air [R ~> kg m-3]. The default is RHO_0. real :: SWH_from_u10sq !< A factor for converting the square of the 10 m wind speed to the !! significant wave height [Z T2 L-2 ~> s2 m-1] real :: Charnock_min !< The minimum value of the Charnock coefficient, which relates the square of @@ -334,7 +336,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) if (StatisticalWaves) then CS%WaveMethod = LF17 - call set_LF17_wave_params(param_file, mdl, US, CS) + call set_LF17_wave_params(param_file, mdl, GV, US, CS) if (.not.use_waves) return else CS%WaveMethod = NULL_WaveMethod @@ -500,7 +502,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) "Flag to disable updating DHH85 Stokes drift.", default=.false.) case (LF17_STRING) !Li and Fox-Kemper 17 wind-sea Langmuir number CS%WaveMethod = LF17 - call set_LF17_wave_params(param_file, mdl, US, CS) + call set_LF17_wave_params(param_file, mdl, GV, US, CS) case (EFACTOR_STRING) !Li and Fox-Kemper 16 CS%WaveMethod = EFACTOR case default @@ -578,9 +580,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) end subroutine MOM_wave_interface_init !> Set the parameters that are used to determine the averaged Stokes drift and Langmuir numbers -subroutine set_LF17_wave_params(param_file, mdl, US, CS) +subroutine set_LF17_wave_params(param_file, mdl, GV, US, CS) type(param_file_type), intent(in) :: param_file !< Input parameter structure character(len=*), intent(in) :: mdl !< A module name to use in the get_param calls + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure @@ -596,6 +599,10 @@ subroutine set_LF17_wave_params(param_file, mdl, US, CS) call get_param(param_file, mdl, "RHO_AIR", CS%rho_air, & "A typical density of air at sea level, as used in wave calculations", & units="kg m-3", default=1.225, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "RHO_SFC_WAVES", CS%Rho_ocn, & + "A typical surface density of seawater, as used in wave calculations in "//& + "comparison with the density of air. The default is RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "WAVE_HEIGHT_SCALE_FACTOR", CS%SWH_from_u10sq, & "A factor relating the square of the 10 m wind speed to the significant "//& "wave height, with a default value based on the Pierson-Moskowitz spectrum.", & @@ -713,13 +720,13 @@ end subroutine Update_Surface_Waves !> Constructs the Stokes Drift profile on the model grid based on !! desired coupling options -subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) +subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Thickness [H ~> m or kg m-2] + intent(in) :: dz !< Thickness in height units [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. real, intent(in) :: dt !< Time-step for computing Stokes-tendency [T ~> s] @@ -728,7 +735,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! Local Variables real :: Top, MidPoint, Bottom ! Positions within the layer [Z ~> m] real :: level_thick ! The thickness of each layer [Z ~> m] - real :: DecayScale ! A vertical decay scale in the test profile [Z ~> m] + real :: DecayScale ! A vertical decay scale in the test profile [Z-1 ~> m-1] real :: CMN_FAC ! A nondimensional factor [nondim] real :: WN ! Model wavenumber [Z-1 ~> m-1] real :: UStokes ! A Stokes drift velocity [L T-1 ~> m s-1] @@ -755,8 +762,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) MidPoint = 0.0 do kk = 1,GV%ke Top = Bottom - MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) + MidPoint = Bottom - 0.25*(dz(II,jj,kk)+dz(IIm1,jj,kk)) + Bottom = Bottom - 0.5*(dz(II,jj,kk)+dz(IIm1,jj,kk)) CS%Us_x(II,jj,kk) = CS%TP_STKX0*exp(MidPoint*DecayScale) enddo enddo @@ -768,8 +775,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) MidPoint = 0.0 do kk = 1,GV%ke Top = Bottom - MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + MidPoint = Bottom - 0.25*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) + Bottom = Bottom - 0.5*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) CS%Us_y(ii,JJ,kk) = CS%TP_STKY0*exp(MidPoint*DecayScale) enddo enddo @@ -796,7 +803,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) do kk = 1,GV%ke Top = Bottom IIm1 = max(II-1,1) - level_thick = 0.5*GV%H_to_Z*(h(II,jj,kk)+h(IIm1,jj,kk)) + level_thick = 0.5*(dz(II,jj,kk)+dz(IIm1,jj,kk)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick @@ -854,7 +861,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) do kk = 1,GV%ke Top = Bottom JJm1 = max(JJ-1,1) - level_thick = 0.5*GV%H_to_Z*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + level_thick = 0.5*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick @@ -908,8 +915,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) do kk = 1,GV%ke Top = Bottom IIm1 = max(II-1,1) - MidPoint = Top - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Top - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) + MidPoint = Top - 0.25*(dz(II,jj,kk)+dz(IIm1,jj,kk)) + Bottom = Top - 0.5*(dz(II,jj,kk)+dz(IIm1,jj,kk)) !bgr note that this is using a u-point ii on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non @@ -926,8 +933,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) do kk=1, GV%ke Top = Bottom JJm1 = max(JJ-1,1) - MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + MidPoint = Bottom - 0.25*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) + Bottom = Bottom - 0.5*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) !bgr note that this is using a v-point jj on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non @@ -965,9 +972,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! in the routine it is needed by (e.g. KPP or ePBL). do jj = G%jsc, G%jec do ii = G%isc,G%iec - Top = h(ii,jj,1)*GV%H_to_Z - call get_Langmuir_Number( La, G, GV, US, Top, ustar(ii,jj), ii, jj, & - h(ii,jj,:), CS, Override_MA=.false.) + call get_Langmuir_Number( La, G, GV, US, dz(ii,jj,1), ustar(ii,jj), ii, jj, & + dz(ii,jj,:), CS, Override_MA=.false.) CS%La_turb(ii,jj) = La enddo enddo @@ -1138,7 +1144,7 @@ end subroutine Surface_Bands_by_data_override !! Note this can be called with an unallocated Waves pointer, which is okay if we !! want the wind-speed only dependent Langmuir number. Therefore, we need to be !! careful about what we try to access here. -subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & +subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, & U_H, V_H, Override_MA ) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -1148,7 +1154,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & real, intent(in) :: ustar !< Friction velocity [Z T-1 ~> m s-1] integer, intent(in) :: i !< Meridional index of h-point integer, intent(in) :: j !< Zonal index of h-point - real, dimension(SZK_(GV)), intent(in) :: h !< Grid layer thickness [H ~> m or kg m-2] + real, dimension(SZK_(GV)), intent(in) :: dz !< Grid layer thickness [Z ~> m] type(Wave_parameters_CS), pointer :: Waves !< Surface wave control structure. real, dimension(SZK_(GV)), & optional, intent(in) :: U_H !< Zonal velocity at H point [L T-1 ~> m s-1] or [m s-1] @@ -1161,7 +1167,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & !Local Variables - real :: Top, bottom, midpoint ! Positions within each layer [Z ~> m] + real :: Top, Bottom, MidPoint ! Positions within each layer [Z ~> m] real :: Dpt_LASL ! Averaging depth for Stokes drift [Z ~> m] real :: ShearDirection ! Shear angular direction from atan2 [radians] real :: WaveDirection ! Wave angular direction from atan2 [radians] @@ -1185,8 +1191,11 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & bottom = 0.0 do kk = 1,GV%ke Top = Bottom - MidPoint = Bottom + GV%H_to_Z*0.5*h(kk) - Bottom = Bottom + GV%H_to_Z*h(kk) + MidPoint = Bottom + 0.5*dz(kk) + Bottom = Bottom + dz(kk) + !### Given the sign convention that Dpt_LASL is negative, the next line seems to have a bug. + ! To correct this bug, this line should be changed to: + ! if (MidPoint > abs(Dpt_LASL) .and. (kk > 1) .and. ContinueLoop) then if (MidPoint > Dpt_LASL .and. kk > 1 .and. ContinueLoop) then ShearDirection = atan2(V_H(1)-V_H(kk),U_H(1)-U_H(kk)) ContinueLoop = .false. @@ -1199,8 +1208,8 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & US_H(kk) = 0.5*(Waves%US_X(I,j,kk)+Waves%US_X(I-1,j,kk)) VS_H(kk) = 0.5*(Waves%US_Y(i,J,kk)+Waves%US_Y(i,J-1,kk)) enddo - call Get_SL_Average_Prof( GV, Dpt_LASL, h, US_H, LA_STKx) - call Get_SL_Average_Prof( GV, Dpt_LASL, h, VS_H, LA_STKy) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX*LA_STKX+LA_STKY*LA_STKY) elseif (Waves%WaveMethod==SURFBANDS) then allocate(StkBand_X(Waves%NumBands), StkBand_Y(Waves%NumBands)) @@ -1218,11 +1227,11 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & US_H(kk) = 0.5*(Waves%US_X(I,j,kk)+Waves%US_X(I-1,j,kk)) VS_H(kk) = 0.5*(Waves%US_Y(i,J,kk)+Waves%US_Y(i,J-1,kk)) enddo - call Get_SL_Average_Prof( GV, Dpt_LASL, h, US_H, LA_STKx) - call Get_SL_Average_Prof( GV, Dpt_LASL, h, VS_H, LA_STKy) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) elseif (Waves%WaveMethod==LF17) then - call get_StokesSL_LiFoxKemper(ustar, hbl*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) + call get_StokesSL_LiFoxKemper(ustar, HBL*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) elseif (Waves%WaveMethod==Null_WaveMethod) then call MOM_error(FATAL, "Get_Langmuir_number called without defining a WaveMethod. "//& "Suggest to make sure USE_LT is set/overridden to False or choose "//& @@ -1322,7 +1331,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! This code should be revised to minimize the number of divisions and cancel out common factors. ! Computing u10 based on u_star and COARE 3.5 relationships - call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/CS%rho_air), u10, GV, US, CS) + call ust_2_u10_coare3p5(ustar*sqrt(CS%rho_ocn/CS%rho_air), u10, GV, US, CS) ! surface Stokes drift UStokes = us_to_u10*u10 ! @@ -1406,19 +1415,19 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) end subroutine Get_StokesSL_LiFoxKemper !> Get SL Averaged Stokes drift from a Stokes drift Profile -subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) +subroutine Get_SL_Average_Prof( GV, AvgDepth, dz, Profile, Average ) type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid structure - real, intent(in) :: AvgDepth !< Depth to average over (negative) [Z ~> m]. + real, intent(in) :: AvgDepth !< Depth to average over (negative) [Z ~> m] real, dimension(SZK_(GV)), & - intent(in) :: H !< Grid thickness [H ~> m or kg m-2] + intent(in) :: dz !< Grid thickness [Z ~> m] real, dimension(SZK_(GV)), & intent(in) :: Profile !< Profile of quantity to be averaged in arbitrary units [A] !! (used here for Stokes drift) real, intent(out) :: Average !< Output quantity averaged over depth AvgDepth [A] !! (used here for Stokes drift) !Local variables - real :: top, midpoint, bottom ! Depths, negative downward [Z ~> m]. + real :: Top, Bottom ! Depths, negative downward [Z ~> m] real :: Sum ! The depth weighted vertical sum of a quantity [A Z ~> A m] integer :: kk @@ -1429,10 +1438,9 @@ subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) bottom = 0.0 do kk = 1, GV%ke Top = Bottom - MidPoint = Bottom - GV%H_to_Z * 0.5*h(kk) - Bottom = Bottom - GV%H_to_Z * h(kk) + Bottom = Bottom - dz(kk) if (AvgDepth < Bottom) then ! The whole cell is within H_LA - Sum = Sum + Profile(kk) * (GV%H_to_Z * H(kk)) + Sum = Sum + Profile(kk) * dz(kk) elseif (AvgDepth < Top) then ! A partial cell is within H_LA Sum = Sum + Profile(kk) * (Top-AvgDepth) exit @@ -1546,7 +1554,7 @@ end subroutine DHH85_mid !> Explicit solver for Stokes mixing. !! Still in development do not use. -subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) +subroutine StokesMixing(G, GV, dt, h, dz, u, v, Waves ) type(ocean_grid_type), & intent(in) :: G !< Ocean grid type(verticalGrid_type), & @@ -1554,6 +1562,8 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) real, intent(in) :: dt !< Time step of MOM6 [T ~> s] for explicit solver real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Vertical distance between interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: u !< Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -1561,8 +1571,9 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. ! Local variables - real :: dTauUp, dTauDn ! Vertical momentum fluxes [Z L T-2 ~> m2 s-2] - real :: h_Lay ! The layer thickness at a velocity point [Z ~> m]. + real :: dTauUp, dTauDn ! Vertical momentum fluxes [H L T-2 ~> m2 s-2 or Pa] + real :: h_lay ! The layer thickness at a velocity point [H ~> m or kg m-2] + real :: dz_lay ! The distance between interfaces at a velocity point [Z ~> m] integer :: i, j, k ! This is a template to think about down-Stokes mixing. @@ -1571,18 +1582,19 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) do k = 1, GV%ke do j = G%jsc, G%jec do I = G%iscB, G%iecB - h_lay = GV%H_to_Z*0.5*(h(i,j,k)+h(i+1,j,k)) + h_lay = 0.5*(h(i,j,k)+h(i+1,j,k)) + dz_lay = 0.5*(dz(i,j,k)+dz(i+1,j,k)) dTauUp = 0.0 if (k > 1) & - dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i+1,j,k)) * & + dTauUp = (0.5*(waves%Kvs(i,j,k)+waves%Kvs(i+1,j,k))) * & (waves%us_x(i,j,k-1)-waves%us_x(i,j,k)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k-1)+h(i+1,j,k-1)) )) + (0.5*(dz_lay + 0.5*(dz(i,j,k-1)+dz(i+1,j,k-1)) )) dTauDn = 0.0 if (k < GV%ke-1) & - dTauDn = 0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i+1,j,k+1)) * & + dTauDn = (0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i+1,j,k+1))) * & (waves%us_x(i,j,k)-waves%us_x(i,j,k+1)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k+1)+h(i+1,j,k+1)) )) - u(i,j,k) = u(i,j,k) + dt * (dTauUp-dTauDn) / h_Lay + (0.5*(dz_lay + 0.5*(dz(i,j,k+1)+dz(i+1,j,k+1)) )) + u(i,j,k) = u(i,j,k) + dt * (dTauUp-dTauDn) / h_lay enddo enddo enddo @@ -1590,18 +1602,19 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) do k = 1, GV%ke do J = G%jscB, G%jecB do i = G%isc, G%iec - h_Lay = GV%H_to_Z*0.5*(h(i,j,k)+h(i,j+1,k)) + h_lay = 0.5*(h(i,j,k)+h(i,j+1,k)) + dz_lay = 0.5*(dz(i,j,k)+dz(i,j+1,k)) dTauUp = 0. if (k > 1) & - dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i,j+1,k)) * & + dTauUp = (0.5*(waves%Kvs(i,j,k)+waves%Kvs(i,j+1,k))) * & (waves%us_y(i,j,k-1)-waves%us_y(i,j,k)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k-1)+h(i,j+1,k-1)) )) + (0.5*(dz_lay + 0.5*(dz(i,j,k-1)+dz(i,j+1,k-1)) )) dTauDn = 0.0 if (k < GV%ke-1) & - dTauDn =0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i,j+1,k+1)) * & + dTauDn = (0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i,j+1,k+1))) * & (waves%us_y(i,j,k)-waves%us_y(i,j,k+1)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k+1)+h(i,j+1,k+1)) )) - v(i,J,k) = v(i,J,k) + dt * (dTauUp-dTauDn) / h_Lay + (0.5*(dz_lay + 0.5*(dz(i,j,k+1)+dz(i,j+1,k+1)) )) + v(i,J,k) = v(i,J,k) + dt * (dTauUp-dTauDn) / h_lay enddo enddo enddo @@ -1658,13 +1671,15 @@ end subroutine CoriolisStokes !! including analytical integration of Stokes shear using multiple-exponential decay !! Stokes drift profile and vertical integration of the resulting pressure !! anomaly to the total pressure gradient force -subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) +subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) type(ocean_grid_type), & intent(in) :: G !< Ocean grid type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), & + intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)),& - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + intent(in) :: dz !< Layer thicknesses in height units [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(in) :: u !< Lagrangian Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & @@ -1737,12 +1752,13 @@ subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) zi_l(1) = 0.0 zi_r(1) = 0.0 do k = 1, G%ke - h_l = h(i,j,k)*GV%H_to_Z - h_r = h(i+1,j,k)*GV%H_to_Z + h_l = dz(i,j,k) + h_r = dz(i+1,j,k) zi_l(k+1) = zi_l(k) - h_l zi_r(k+1) = zi_r(k) - h_r - Idz_l(k) = 1./max(0.1,h_l) - Idz_r(k) = 1./max(0.1,h_r) + !### If the code were properly refactored, the following hard-coded constants would be unnecessary. + Idz_l(k) = 1./max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1./max(0.1*US%m_to_Z, h_r) enddo do k = 1,G%ke ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the @@ -1830,12 +1846,13 @@ subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) zi_l(1) = 0.0 zi_r(1) = 0.0 do k = 1, G%ke - h_l = h(i,j,k)*GV%H_to_Z - h_r = h(i,j+1,k)*GV%H_to_Z + h_l = dz(i,j,k) + h_r = dz(i,j+1,k) zi_l(k+1) = zi_l(k) - h_l zi_r(k+1) = zi_r(k) - h_r - Idz_l(k) = 1./max(0.1,h_l) - Idz_r(k) = 1./max(0.1,h_r) + !### If the code were properly refactored, the following hard-coded constants would be unnecessary. + Idz_l(k) = 1. / max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1. / max(0.1*US%m_to_Z, h_r) enddo do k = 1,G%ke ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the From 8f7cc0e19022ba1bb961e1e874aff5474b60d2fc Mon Sep 17 00:00:00 2001 From: claireyung <61528379+claireyung@users.noreply.github.com> Date: Mon, 7 Aug 2023 19:07:47 +1000 Subject: [PATCH 038/146] Ice shelf melt parameterization fixes (#395) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two fixes to the ice shelf melt parameterization in MOM_ice_shelf.F90: (1) the removal of an extra von Kármán constant which differs from the Holland and Jenkins (1999) formulation. My working is detailed in this document. (2) a modification to the it3 loop in shelf_calc_flux subroutine, which currently does not iterate because wB_flux does not get updated to its new value via the Newton solver method. Instead, the loop either runs 30 times with the same value, or is below the threshold and exits on the first loop. I added a line to update the value of wB_flux. Specific changes include: * Remove KV in n_star_term definition * Add line to ice shelf param it3 to correct iteration * Reinstate von Karman constant and rearrange to remove double division * Remove unneeded salt iteration line that overrides option of using false position method * Change value of ZETA_N to be consistent with Holland & Jenkins 99 * Fix typo, ZETA_N should be 0.13 not 0.013 * Add parameter for ZETA_N * Make RC and VK runtime parameters * Add runtime parameters to fix buoyancy iteration bug and salt overwriting false position method bug * Add runtime parameter for buoyancy iteration Newton's method convergence criteria --- src/ice_shelf/MOM_ice_shelf.F90 | 49 +++++++++++++++++++++++++++------ 1 file changed, 40 insertions(+), 9 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 8e0e58c1b6..d0faeb3aae 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -185,6 +185,14 @@ module MOM_ice_shelf !! salinity [C S-1 ~> degC ppt-1] real :: dTFr_dp !< Partial derivative of freezing temperature with !! pressure [C T2 R-1 L-2 ~> degC Pa-1] + real :: Zeta_N !< The stability constant xi_N = 0.052 from Holland & Jenkins '99 + !! divided by the von Karman constant VK. Was 1/8. + real :: Vk !< Von Karman's constant - dimensionless + real :: Rc !< critical flux Richardson number. + logical :: buoy_flux_itt_bug !< If true, fixes buoyancy iteration bug + logical :: salt_flux_itt_bug !< If true, fixes salt iteration bug + real :: buoy_flux_itt_threshold !< Buoyancy iteration threshold for convergence + !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & @@ -261,10 +269,10 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) !! interface, positive for melting and negative for freezing [S ~> ppt]. !! This is computed as part of the ISOMIP diagnostics. real :: time_step !< Length of time over which these fluxes will be applied [T ~> s]. - real, parameter :: VK = 0.40 !< Von Karman's constant - dimensionless - real :: ZETA_N = 0.052 !> The fraction of the boundary layer over which the - !! viscosity is linearly increasing [nondim]. (Was 1/8. Why?) - real, parameter :: RC = 0.20 ! critical flux Richardson number. + real :: VK !< Von Karman's constant - dimensionless + real :: ZETA_N !< This is the stability constant xi_N = 0.052 from Holland & Jenkins '99 + !! divided by the von Karman constant VK. Was 1/8. [nondim] + real :: RC !< critical flux Richardson number. real :: I_ZETA_N !< The inverse of ZETA_N [nondim]. real :: I_LF !< The inverse of the latent heat of fusion [Q-1 ~> kg J-1]. real :: I_VK !< The inverse of the Von Karman constant [nondim]. @@ -346,6 +354,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) endif ! useful parameters is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed + ZETA_N = CS%Zeta_N + VK = CS%Vk + RC = CS%Rc I_ZETA_N = 1.0 / ZETA_N I_LF = 1.0 / CS%Lat_fusion SC = CS%kv_molec/CS%kd_molec_salt @@ -527,7 +538,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (wB_flux < 0.0) then ! The buoyancy flux is stabilizing and will reduce the turbulent ! fluxes, and iteration is required. - n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (ustar_h)**3 + n_star_term = (ZETA_N * hBL_neut * VK) / (RC * ustar_h**3) do it3 = 1,30 ! n_star <= 1.0 is the ratio of working boundary layer thickness ! to the neutral thickness. @@ -558,13 +569,15 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) wT_flux = dT_ustar * I_Gam_T wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux - ! Find the root where wB_flux_new = wB_flux. Make the 1.0e-4 below into a parameter? - if (abs(wB_flux_new - wB_flux) < 1.0e-4*(abs(wB_flux_new) + abs(wB_flux))) exit + ! Find the root where wB_flux_new = wB_flux. + if (abs(wB_flux_new - wB_flux) < CS%buoy_flux_itt_threshold*(abs(wB_flux_new) + abs(wB_flux))) exit dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 ! This is Newton's method without any bounds. Should bounds be needed? wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in + ! Update wB_flux + if (CS%buoy_flux_itt_bug) wB_flux = wB_flux_new enddo !it3 endif @@ -637,7 +650,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) Sbdry(i,j) = Sbdry_it endif ! Sb_min_set - Sbdry(i,j) = Sbdry_it + if (.not.CS%salt_flux_itt_bug) Sbdry(i,j) = Sbdry_it + endif ! CS%find_salt_root enddo !it1 @@ -1514,7 +1528,24 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) - + call get_param(param_file, mdl, "ICE_SHELF_LINEAR_SHELF_FRAC", CS%Zeta_N, & + "Ratio of HJ99 stability constant xi_N (ratio of maximum "//& + "mixing length to planetary boundary layer depth in "//& + "neutrally stable conditions) to the von Karman constant", & + units="nondim", default=0.13) + call get_param(param_file, mdl, "ICE_SHELF_VK_CNST", CS%Vk, & + "Von Karman constant.", & + units="nondim", default=0.40) + call get_param(param_file, mdl, "ICE_SHELF_RC", CS%Rc, & + "Critical flux Richardson number for ice melt ", & + units="nondim", default=0.20) + call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_BUG", CS%buoy_flux_itt_bug, & + "Bug fix of buoyancy iteration", default=.true.) + call get_param(param_file, mdl, "ICE_SHELF_SALT_FLUX_ITT_BUG", CS%salt_flux_itt_bug, & + "Bug fix of salt iteration", default=.true.) + call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_THRESHOLD", CS%buoy_flux_itt_threshold, & + "Convergence criterion of Newton's method for ice shelf "//& + "buoyancy iteration.", units="nondim", default=1.0e-4) if (PRESENT(sfc_state_in)) then allocate(sfc_state) From 46c52622cf1d7a39ea9919279bed0b652aad96b7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 20 Jun 2023 07:36:26 -0400 Subject: [PATCH 039/146] *Use tv%SpV_avg in non-Boussinesq regridding Use SpV_avg in both hybgen_unmix and regridding_main to estimate the nominal ocean bottom depth in thickness units when in fully non-Boussinesq mode. This change eliminates certain dependencies on the Boussinesq reference density via GV%Z_to_H. Also added a call to calc_derived_thermo in ALE_regrid_accelerated that is necessary for the specific volume to be updated, along with tests for the validity of the specific volume with the 1-point halos that are currently used with ALE regridding and remapping. Also, use the total thickness place of the nominal depth in build_grid_rho and build_grid_sigma when in fully non-Boussinesq mode. This is mathematically equivalent but changes answers at roundoff. All answers are bitwise identical in Boussinesq mode, but ALE-based solutions change in fully non-Boussinesq mode with this commit. --- src/ALE/MOM_ALE.F90 | 5 ++- src/ALE/MOM_hybgen_unmix.F90 | 42 ++++++++++++++++++++----- src/ALE/MOM_regridding.F90 | 61 ++++++++++++++++++++++++++---------- 3 files changed, 83 insertions(+), 25 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 2e16933525..b8f60b2830 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -20,7 +20,7 @@ module MOM_ALE use MOM_hybgen_unmix, only : hybgen_unmix, init_hybgen_unmix, end_hybgen_unmix, hybgen_unmix_CS use MOM_hybgen_regrid, only : hybgen_regrid_CS use MOM_file_parser, only : get_param, param_file_type, log_param -use MOM_interface_heights,only : find_eta +use MOM_interface_heights,only : find_eta, calc_derived_thermo use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_regridding, only : initialize_regridding, regridding_main, end_regridding @@ -659,6 +659,9 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! generate new grid if (CS%do_conv_adj) call convective_adjustment(G, GV, h_loc, tv_local) + ! Update the layer specific volumes if necessary + if (allocated(tv_local%SpV_avg)) call calc_derived_thermo(tv_local, h, G, GV, US, halo=1) + call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface) dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) diff --git a/src/ALE/MOM_hybgen_unmix.F90 b/src/ALE/MOM_hybgen_unmix.F90 index 024a9baffa..6ddb828abe 100644 --- a/src/ALE/MOM_hybgen_unmix.F90 +++ b/src/ALE/MOM_hybgen_unmix.F90 @@ -9,6 +9,7 @@ module MOM_hybgen_unmix use MOM_file_parser, only : get_param, param_file_type, log_param use MOM_hybgen_regrid, only : hybgen_column_init use MOM_hybgen_regrid, only : hybgen_regrid_CS, get_hybgen_regrid_params +use MOM_interface_heights, only : calc_derived_thermo use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_grid_type, thermo_var_ptrs @@ -146,7 +147,8 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) real :: p_col(GV%ke) ! A column of reference pressures [R L2 T-2 ~> Pa] real :: tracer(GV%ke,max(ntr,1)) ! Columns of each tracer [Conc] real :: h_tot ! Total thickness of the water column [H ~> m or kg m-2] - real :: nominalDepth ! Depth of ocean bottom (positive downward) [H ~> m or kg m-2] + real :: dz_tot ! Vertical distance between the top and bottom of the water column [Z ~> m] + real :: nominalDepth ! Depth of ocean bottom in thickness units (positive downward) [H ~> m or kg m-2] real :: h_thin ! A negligibly small thickness to identify essentially ! vanished layers [H ~> m or kg m-2] real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] @@ -169,6 +171,15 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) h_thin = 1e-6*GV%m_to_H debug_conservation = .false. ! Set this to true for debugging + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < 1)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + mesg = "insufficiently large SpV_avg halos of width 0 but 1 is needed." + endif + call MOM_error(FATAL, "hybgen_unmix called in fully non-Boussinesq mode with "//trim(mesg)) + endif + p_col(:) = CS%ref_pressure do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then @@ -203,13 +214,27 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) endif ! The following block of code is used to trigger z* stretching of the targets heights. - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H - if (h_tot <= CS%min_dilate*nominalDepth) then - dilate = CS%min_dilate - elseif (h_tot >= CS%max_dilate*nominalDepth) then - dilate = CS%max_dilate + if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussiesq version + dz_tot = 0.0 + do k=1,nk + dz_tot = dz_tot + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h_col(k) + enddo + if (dz_tot <= CS%min_dilate*(G%bathyT(i,j)+G%Z_ref)) then + dilate = CS%min_dilate + elseif (dz_tot >= CS%max_dilate*(G%bathyT(i,j)+G%Z_ref)) then + dilate = CS%max_dilate + else + dilate = dz_tot / (G%bathyT(i,j)+G%Z_ref) + endif else - dilate = h_tot / nominalDepth + nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + if (h_tot <= CS%min_dilate*nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate*nominalDepth) then + dilate = CS%max_dilate + else + dilate = h_tot / nominalDepth + endif endif terrain_following = (h_tot < dilate*CS%dpns) .and. (CS%dpns >= CS%dsns) @@ -268,6 +293,9 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) endif endif ; enddo ; enddo !i & j. + ! Update the layer properties + if (allocated(tv%SpV_avg)) call calc_derived_thermo(tv, h, G, GV, US, halo=1) + end subroutine hybgen_unmix diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 5c4a76c7e5..c238c2aa61 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -814,20 +814,47 @@ subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & ! Local variables real :: nom_depth_H(SZI_(G),SZJ_(G)) !< The nominal ocean depth at each point in thickness units [H ~> m or kg m-2] + real :: tot_h(SZI_(G),SZJ_(G)) !< The total thickness of the water column [H ~> m or kg m-2] + real :: tot_dz(SZI_(G),SZJ_(G)) !< The total distance between the top and bottom of the water column [Z ~> m] real :: Z_to_H ! A conversion factor used by some routines to convert coordinate ! parameters to depth units [H Z-1 ~> nondim or kg m-3] real :: trickGnuCompiler - integer :: i, j + character(len=128) :: mesg ! A string for error messages + integer :: i, j, k if (present(PCM_cell)) PCM_cell(:,:,:) = .false. Z_to_H = US%Z_to_m * GV%m_to_H ! Often this is equivalent to GV%Z_to_H. - do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - nom_depth_H(i,j) = (G%bathyT(i,j)+G%Z_ref) * Z_to_H - ! Consider using the following instead: - ! nom_depth_H(i,j) = max( (G%bathyT(i,j)+G%Z_ref) * Z_to_H , CS%min_nom_depth ) - ! if (G%mask2dT(i,j)==0.) nom_depth_H(i,j) = 0.0 - enddo ; enddo + + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < 1)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + mesg = "insufficiently large SpV_avg halos of width 0 but 1 is needed." + endif + call MOM_error(FATAL, "Regridding_main called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussinesq case + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + tot_h(i,j) = 0.0 ; tot_dz(i,j) = 0.0 + enddo ; enddo + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + tot_h(i,j) = tot_h(i,j) + h(i,j,k) + tot_dz(i,j) = tot_dz(i,j) + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h(i,j,k) + enddo ; enddo ; enddo + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + if ((tot_dz(i,j) > 0.0) .and. (G%bathyT(i,j)+G%Z_ref > 0.0)) then + nom_depth_H(i,j) = (G%bathyT(i,j)+G%Z_ref) * (tot_h(i,j) / tot_dz(i,j)) + else + nom_depth_H(i,j) = 0.0 + endif + enddo ; enddo + else + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + nom_depth_H(i,j) = max((G%bathyT(i,j)+G%Z_ref) * Z_to_H, 0.0) + enddo ; enddo + endif select case ( CS%regridding_scheme ) @@ -1308,12 +1335,12 @@ subroutine build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) ! In sigma coordinates, the bathymetric depth is only used as an arbitrary offset that ! cancels out when determining coordinate motion, so referencing the column postions to ! the surface is perfectly acceptable, but for preservation of previous answers the - ! referencing is done relative to the bottom when in Boussinesq mode. - ! if (GV%Boussinesq) then + ! referencing is done relative to the bottom when in Boussinesq or semi-Boussinesq mode. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then nominalDepth = nom_depth_H(i,j) - ! else - ! nominalDepth = totalThickness - ! endif + else + nominalDepth = totalThickness + endif call build_sigma_column(CS%sigma_CS, nominalDepth, totalThickness, zNew) @@ -1436,12 +1463,12 @@ subroutine build_rho_grid( G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, ! In rho coordinates, the bathymetric depth is only used as an arbitrary offset that ! cancels out when determining coordinate motion, so referencing the column postions to ! the surface is perfectly acceptable, but for preservation of previous answers the - ! referencing is done relative to the bottom when in Boussinesq mode. - ! if (GV%Boussinesq) then + ! referencing is done relative to the bottom when in Boussinesq or semi-Boussinesq mode. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then nominalDepth = nom_depth_H(i,j) - ! else - ! nominalDepth = totalThickness - ! endif + else + nominalDepth = totalThickness + endif ! Determine absolute interface positions zOld(nz+1) = - nominalDepth From ba70663e3e2d688e6a11bedd891fe3b5bee7b3fc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Aug 2023 08:38:42 -0400 Subject: [PATCH 040/146] *Non-Boussinesq revision of diabatic_driver This commit completes the non-Boussinesq revision of the diabatic_driver code. The revised code uses thickness_to_dz and works with internal variables in vertical distances in the denominator of diffusive flux calculations in diabatic_ALE_legacy, diabatic_ALE and layered_diabatic. The code now uses find_ustar to extract the friction velocities passed to KPP_compute. The (tiny) boundary layer tracer diffusivity is also rescaled to [H2 T-1]. With this set of changes, all implicit references to Boussinesq reference density are eliminated from the calculations in diabatic_driver when in non-Boussinesq mode. A total of 14 thickness rescaling factors were cancelled out, and there are 15 new or renamed variables in the diabatic routines. 4 new checksum calls are also added to diabatic_ALE_legacy to assist in debugging. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode the use of the layer averaged specific volume to convert thicknesses to vertical distances leads to changing answers. --- .../vertical/MOM_diabatic_driver.F90 | 170 +++++++++++------- 1 file changed, 107 insertions(+), 63 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index dae52592e9..b2b8527819 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -12,8 +12,9 @@ module MOM_diabatic_driver use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used use MOM_diabatic_aux, only : diabatic_aux_init, diabatic_aux_end, diabatic_aux_CS use MOM_diabatic_aux, only : make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS -use MOM_diabatic_aux, only : triDiagTS_Eulerian, find_uv_at_h, diagnoseMLDbyDensityDifference -use MOM_diabatic_aux, only : applyBoundaryFluxesInOut, diagnoseMLDbyEnergy, set_pen_shortwave +use MOM_diabatic_aux, only : triDiagTS_Eulerian, find_uv_at_h +use MOM_diabatic_aux, only : applyBoundaryFluxesInOut, set_pen_shortwave +use MOM_diabatic_aux, only : diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_sum_u, post_product_sum_v use MOM_diag_mediator, only : diag_ctrl, time_type, diag_update_remap_grids @@ -36,14 +37,14 @@ module MOM_diabatic_driver use MOM_error_handler, only : MOM_error, FATAL, WARNING, callTree_showQuery,MOM_mesg use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_version, param_file_type, read_param -use MOM_forcing_type, only : forcing, MOM_forcing_chksum +use MOM_forcing_type, only : forcing, MOM_forcing_chksum, find_ustar use MOM_forcing_type, only : calculateBuoyancyFlux2d, forcing_SinglePointPrint use MOM_geothermal, only : geothermal_entraining, geothermal_in_place use MOM_geothermal, only : geothermal_init, geothermal_end, geothermal_CS use MOM_grid, only : ocean_grid_type use MOM_int_tide_input, only : set_int_tide_input, int_tide_input_init use MOM_int_tide_input, only : int_tide_input_end, int_tide_input_CS, int_tide_input_type -use MOM_interface_heights, only : find_eta, calc_derived_thermo +use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz use MOM_internal_tides, only : propagate_int_tide use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS use MOM_kappa_shear, only : kappa_shear_is_used @@ -145,8 +146,8 @@ module MOM_diabatic_driver !! diffusivity of Kd_min_tr (see below) were operating. real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes - !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. The entrainment at the bottom is at - !! least sqrt(Kd_BBL_tr*dt) over the same distance. + !! [H2 T-1 ~> m2 s-1 or kg2 m-4 s-2]. The entrainment at the + !! bottom is at least sqrt(Kd_BBL_tr*dt) over the same distance. real :: Kd_min_tr !< A minimal diffusivity that should always be !! applied to tracers, especially in massless layers !! near the bottom [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -170,8 +171,6 @@ module MOM_diabatic_driver real :: MLD_En_vals(3) !< Energy values for energy mixed layer diagnostics [R Z3 T-2 ~> J m-2] !>@{ Diagnostic IDs - integer :: id_cg1 = -1 ! diagnostic handle for mode-1 speed - integer, allocatable, dimension(:) :: id_cn ! diagnostic handle for all mode speeds integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_int = -1, id_Kd_ePBL = -1 @@ -530,6 +529,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_orig, & ! Initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. @@ -555,6 +555,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)) :: & + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL logical, dimension(SZI_(G)) :: & @@ -562,11 +563,11 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! sufficiently thick that the no-flux boundary conditions have not restricted ! the entrainment - usually sqrt(Kd*dt). - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2] - real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] - real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] + real :: I_dzval ! The inverse of the thicknesses averaged to interfaces [Z-1 ~> m-1] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. @@ -580,7 +581,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 showCallTree = callTree_showQuery() @@ -674,19 +676,22 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + U_star, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif if (associated(Hml)) then @@ -775,15 +780,18 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_int, visc%Kv_shear) endif + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US) + ! This block sets ent_t and ent_s from h and Kd_int. do j=js,je ; do i=is,ie ent_s(i,j,1) = 0.0 ; ent_s(i,j,nz+1) = 0.0 ent_t(i,j,1) = 0.0 ; ent_t(i,j,nz+1) = 0.0 enddo ; enddo - !$OMP parallel do default(shared) private(I_hval) + !$OMP parallel do default(shared) private(I_dzval) do K=2,nz ; do j=js,je ; do i=is,ie - I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_s(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_int(i,j,K) + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + ent_s(i,j,K) = dt * I_dzval * Kd_int(i,j,K) ent_t(i,j,K) = ent_s(i,j,K) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_s and ent_t from Kd_int (diabatic)") @@ -826,6 +834,11 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim scale=US%kg_m3_to_R*US%degC_to_C) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & scale=US%kg_m3_to_R*US%ppt_to_S) + call hchksum(h, "after applyBoundaryFluxes h", G%HI, haloshift=0, scale=GV%H_to_mks) + call hchksum(tv%T, "after applyBoundaryFluxes tv%T", G%HI, haloshift=0, scale=US%C_to_degC) + call hchksum(tv%S, "after applyBoundaryFluxes tv%S", G%HI, haloshift=0, scale=US%S_to_ppt) + call hchksum(SkinBuoyFlux, "after applyBdryFlux SkinBuoyFlux", G%HI, haloshift=0, & + scale=US%Z_to_m**2*US%s_to_T**3) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -846,6 +859,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) endif + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then @@ -856,7 +872,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) endif - Ent_int = Kd_add_here * (GV%Z_to_H * dt) / (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) + Ent_int = Kd_add_here * dt / (0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) ent_s(i,j,K) = ent_s(i,j,K) + Ent_int Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here @@ -877,6 +893,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + endif ! endif for CS%use_energetic_PBL ! diagnose the tendencies due to boundary forcing @@ -1002,7 +1021,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je @@ -1021,8 +1040,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_int, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & - ((h(i,j,k-1)+h(i,j,k)+h_neglect) / (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & + add_ent = ((dt * CS%Kd_min_tr)) * & + ((dz(i,j,k-1)+dz(i,j,k)+dz_neglect) / (dz(i,j,k-1)*dz(i,j,k)+dz_neglect2)) - & 0.5*(ent_s(i,j,K) + ent_s(i,j,K)) if (htot(i) < Tr_ea_BBL) then add_ent = max(0.0, add_ent, (Tr_ea_BBL - htot(i)) - ent_s(i,j,K)) @@ -1034,8 +1053,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H) / & - (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) + add_ent = (dt * Kd_extra_S(i,j,k)) / & + (0.5 * (dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) ent_s(i,j,K) = ent_s(i,j,K) + add_ent endif ; endif enddo ; enddo @@ -1045,8 +1064,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H) / & - (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) + add_ent = (dt * Kd_extra_S(i,j,k)) / & + (0.5 * (dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) else add_ent = 0.0 endif @@ -1126,6 +1145,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_orig, & ! Initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. @@ -1151,18 +1171,18 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)) :: & + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL logical, dimension(SZI_(G)) :: & in_boundary ! True if there are no massive layers below, where massive is defined as ! sufficiently thick that the no-flux boundary conditions have not restricted ! the entrainment - usually sqrt(Kd*dt). - - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2] - real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] - real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] + real :: I_dzval ! The inverse of the thicknesses averaged to interfaces [Z-1 ~> m-1] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. @@ -1174,7 +1194,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 ent_s(:,:,:) = 0.0 ; ent_t(:,:,:) = 0.0 @@ -1276,18 +1297,21 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + U_star, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -1464,17 +1488,20 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo endif + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + ! set ent_t=dt*Kd_heat/h_int and est_s=dt*Kd_salt/h_int on interfaces for use in the tridiagonal solver. do j=js,je ; do i=is,ie ent_t(i,j,1) = 0. ; ent_t(i,j,nz+1) = 0. ent_s(i,j,1) = 0. ; ent_s(i,j,nz+1) = 0. enddo ; enddo - !$OMP parallel do default(shared) private(I_hval) + !$OMP parallel do default(shared) private(I_dzval) do K=2,nz ; do j=js,je ; do i=is,ie - I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_t(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_heat(i,j,k) - ent_s(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_salt(i,j,k) + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + ent_t(i,j,K) = dt * I_dzval * Kd_heat(i,j,k) + ent_s(i,j,K) = dt * I_dzval * Kd_salt(i,j,k) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_t and ent_t from Kd_heat and " //& "Kd_salt (diabatic_ALE)") @@ -1540,7 +1567,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -1554,8 +1581,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! bottom, add some mixing of tracers between these layers. This flux is based on the ! harmonic mean of the two thicknesses, following what is done in layered mode. Kd_min_tr ! should be much less than the values in Kd_salt, perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & - ((h(i,j,k-1)+h(i,j,k) + h_neglect) / (h(i,j,k-1)*h(i,j,k) + h_neglect2)) - & + add_ent = (dt * CS%Kd_min_tr) * & + ((dz(i,j,k-1)+dz(i,j,k) + dz_neglect) / (dz(i,j,k-1)*dz(i,j,k) + dz_neglect2)) - & ent_s(i,j,K) if (htot(i) < Tr_ea_BBL) then add_ent = max(0.0, add_ent, (Tr_ea_BBL - htot(i)) - ent_s(i,j,K)) @@ -1648,13 +1675,17 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! one time step [H ~> m or kg m-2] Kd_lay, & ! diapycnal diffusivity of layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] hold, & ! layer thickness before diapycnal entrainment, and later the initial ! layer thicknesses (if a mixed layer is used) [H ~> m or kg m-2] + dz_old, & ! The initial vertical distance between interfaces around a layer + ! or the distance before entrainment [Z ~> m] u_h, & ! Zonal velocities at thickness points after entrainment [L T-1 ~> m s-1] v_h, & ! Meridional velocities at thickness points after entrainment [L T-1 ~> m s-1] temp_diag, & ! Diagnostic array of previous temperatures [C ~> degC] saln_diag ! Diagnostic array of previous salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G)) :: & + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. Rcv_ml ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & @@ -1697,7 +1728,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2] - real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: net_ent ! The net of ea-eb at an interface [H ~> m or kg m-2] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] real :: eaval ! eaval is 2*ea at velocity grid points [H ~> m or kg m-2] @@ -1724,7 +1757,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nkmb = GV%nk_rho_varies - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 @@ -1885,17 +1919,20 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo ; enddo ; enddo endif + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + U_star, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -2300,8 +2337,15 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! mixing of passive tracers from massless boundary layers to interior call cpu_clock_begin(id_clock_tracers) + + ! Find the vertical distances across layers. + if (CS%mix_boundary_tracers .or. CS%double_diffuse) & + call thickness_to_dz(h, tv, dz, G, GV, US) + if (CS%double_diffuse) & + call thickness_to_dz(hold, tv, dz_old, G, GV, US) + if (CS%mix_boundary_tracers) then - Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -2320,9 +2364,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_lay, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & - ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & - (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & + add_ent = (dt * CS%Kd_min_tr) * & + ((dz(i,j,k-1) + dz(i,j,k) + dz_neglect) / & + (dz(i,j,k-1)*dz(i,j,k) + dz_neglect2)) - & 0.5*(ea(i,j,k) + eb(i,j,k-1)) if (htot(i) < Tr_ea_BBL) then add_ent = max(0.0, add_ent, & @@ -2337,9 +2381,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H) / & - (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & - h_neglect) + add_ent = (dt * Kd_extra_S(i,j,K)) / & + (0.25 * ((dz(i,j,k-1) + dz(i,j,k)) + (dz_old(i,j,k-1) + dz_old(i,j,k))) + dz_neglect) ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent eatr(i,j,k) = eatr(i,j,k) + add_ent endif ; endif @@ -2361,9 +2404,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H) / & - (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & - h_neglect) + add_ent = (dt * Kd_extra_S(i,j,K)) / & + (0.25 * ((dz(i,j,k-1) + dz(i,j,k)) + (dz_old(i,j,k-1) + dz_old(i,j,k))) + dz_neglect) else add_ent = 0.0 endif @@ -3095,7 +3137,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "A bottom boundary layer tracer diffusivity that will "//& "allow for explicitly specified bottom fluxes. The "//& "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) "//& - "over the same distance.", units="m2 s-1", default=0., scale=GV%m2_s_to_HZ_T) + "over the same distance.", & + units="m2 s-1", default=0., scale=GV%m2_s_to_HZ_T*(US%Z_to_m*GV%m_to_H)) + ! The scaling factor here is usually equivalent to GV%m2_s_to_HZ_T*GV%Z_to_H. endif call get_param(param_file, mdl, "TRACER_TRIDIAG", CS%tracer_tridiag, & From 648012edff219ab8f65d6376d6524b60ac12ed29 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 4 Aug 2023 11:39:28 -0800 Subject: [PATCH 041/146] Adding a knob for strength of brine plume mixing. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index f176b0d726..6a5e454d19 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -71,6 +71,7 @@ module MOM_diabatic_aux logical :: do_brine_plume !< If true, insert salt flux below the surface according to !! a parameterization by \cite Nguyen2009. integer :: brine_plume_n !< The exponent in the brine plume parameterization. + real :: plume_strength !< Fraction of the available brine to take to the bottom of the mixed layer. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output @@ -1425,7 +1426,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Place forcing into this layer by depth for brine plume parameterization. if (k == 1) then dK(i) = 0.5 * h(i,j,k) * GV%H_to_Z ! Depth of center of layer K - plume_flux = - (1000.0*US%ppt_to_S * fluxes%salt_left_behind(i,j)) * GV%RZ_to_H + plume_flux = - (1000.0*US%ppt_to_S * (CS%plume_strength * fluxes%salt_left_behind(i,j))) * GV%RZ_to_H plume_fraction = 1.0 else dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K @@ -1440,8 +1441,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t plume_fraction = min(fraction_left_brine, h2d(i,k)*IforcingDepthScale) endif fraction_left_brine = fraction_left_brine - plume_fraction - plume_flux = plume_flux + plume_fraction * (1000.0*US%ppt_to_S * fluxes%salt_left_behind(i,j)) & - * GV%RZ_to_H + plume_flux = plume_flux + plume_fraction * (1000.0*US%ppt_to_S * (CS%plume_strength * & + fluxes%salt_left_behind(i,j))) * GV%RZ_to_H else plume_flux = 0.0 endif @@ -1767,6 +1768,9 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori call get_param(param_file, mdl, "BRINE_PLUME_EXPONENT", CS%brine_plume_n, & "If using the brine plume parameterization, set the integer exponent.", & default=5, do_not_log=.not.CS%do_brine_plume) + call get_param(param_file, mdl, "BRINE_PLUME_FRACTION", CS%plume_strength, & + "Fraction of the available brine to mix down using the brine plume parameterization.", & + units="nondim", default=1.0, do_not_log=.not.CS%do_brine_plume) if (useALEalgorithm) then CS%id_createdH = register_diag_field('ocean_model',"created_H",diag%axesT1, & From 07713af190222538c08aa7fafa99c46ab226d09e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 17:50:21 -0400 Subject: [PATCH 042/146] +*Ignore SURFACE_ANSWER_DATE when non-Boussinesq Ignore SURFACE_ANSWER_DATE in non-Boussinesq mode and always allocate tv%SpV_avg in fully non-Boussinesq mode, setting it to the inverse of the layer densities in calc_derived_thermo() if there is no equation of state. Also when in fully non-Boussinesq mode cancelled out some rescaling factors in dz_to_thickness_EOS and dz_to_thickness_tv. Also revised dz_to_thickness_simple in non-Boussinesq and non-layered mode to use RHO_KV_CONVERT instead of RHO_0 to rescale vertical distances to thicknesses. Also set the default value of CALC_RHO_FOR_SEA_LEVEL to true when fully non-Boussinesq. All Boussinesq answers are bitwise identical, but some non-Boussinesq answers do change and become less dependent on the Boussinesq reference density. Because SURFACE_ANSWER_DATE is no longer being used in non-Boussinesq mode, is is no longer being logged in the MOM_parameter_doc files for these experiments. --- src/core/MOM.F90 | 6 ++-- src/core/MOM_interface_heights.F90 | 44 ++++++++++++++++++++++-------- 2 files changed, 36 insertions(+), 14 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9cbb744560..c9b8ea42c0 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2103,7 +2103,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "CALC_RHO_FOR_SEA_LEVEL", CS%calc_rho_for_sea_lev, & "If true, the in-situ density is used to calculate the "//& "effective sea level that is returned to the coupler. If false, "//& - "the Boussinesq parameter RHO_0 is used.", default=.false.) + "the Boussinesq parameter RHO_0 is used.", default=non_Bous) call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) @@ -2892,8 +2892,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif endif - ! Allocate any derived equation of state fields. - if (use_temperature .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + ! Allocate any derived densities or other equation of state derived fields. + if (.not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then allocate(CS%tv%SpV_avg(isd:ied,jsd:jed,nz), source=0.0) CS%tv%valid_SpV_halo = -1 ! This array does not yet have any valid data. endif diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 1893859fe7..0a579db299 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -279,6 +279,8 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: p_t ! Hydrostatic pressure atop a layer [R L2 T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G)) :: dp ! Pressure change across a layer [R L2 T-2 ~> Pa] + real, dimension(SZK_(GV)) :: SpV_lay ! The specific volume of each layer when no equation of + ! state is used [R-1 ~> m3 kg-1] logical :: do_debug ! If true, write checksums for debugging. integer :: i, j, k, is, ie, js, je, halos, nz @@ -310,6 +312,12 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) call hchksum(tv%T, "derived_thermo T", G%HI, haloshift=halos, scale=US%C_to_degC) call hchksum(tv%S, "derived_thermo S", G%HI, haloshift=halos, scale=US%S_to_ppt) endif + elseif (allocated(tv%Spv_avg)) then + do k=1,nz ; SpV_lay(k) = 1.0 / GV%Rlay(k) ; enddo + do k=1,nz ; do j=js,je ; do i=is,ie + tv%SpV_avg(i,j,k) = SpV_lay(k) + enddo ; enddo ; enddo + tv%valid_SpV_halo = halos endif end subroutine calc_derived_thermo @@ -481,9 +489,7 @@ subroutine dz_to_thickness_tv(dz, tv, h, G, GV, US, halo_size) endif else do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = (GV%Z_to_H*dz(i,j,k)) * (GV%Rlay(k) / GV%Rho0) - ! Consider revising this to the mathematically equivalent expression: - ! h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) + h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) enddo ; enddo ; enddo endif endif @@ -551,10 +557,16 @@ subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_s do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo call calculate_density(Temp(:,j,k), Saln(:,j,k), p_top(:,j), rho, & EoS, EOSdom) - do i=is,ie - ! This could be simplified, but it would change answers at roundoff. - p_bot(i,j) = p_top(i,j) + (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) - enddo + ! The following two expressions are mathematically equivalent. + if (GV%semi_Boussinesq) then + do i=is,ie + p_bot(i,j) = p_top(i,j) + (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) + enddo + else + do i=is,ie + p_bot(i,j) = p_top(i,j) + rho(i) * (GV%g_Earth * dz(i,j,k)) + enddo + endif enddo do itt=1,max_itt @@ -565,9 +577,15 @@ subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_s EoS, EOSdom) ! Use Newton's method to correct the bottom value. ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. - do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) - enddo + if (GV%semi_Boussinesq) then + do i=is,ie + p_bot(i,j) = p_bot(i,j) + rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) + enddo + else + do i=is,ie + p_bot(i,j) = p_bot(i,j) + rho(i) * (GV%g_Earth*dz(i,j,k) - dz_geo(i,j)) + enddo + endif enddo ; endif enddo @@ -608,7 +626,7 @@ subroutine dz_to_thickness_simple(dz, h, G, GV, US, halo_size, layer_mode) layered = .false. ; if (present(layer_mode)) layered = layer_mode is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke - if (GV%Boussinesq .or. (.not.layered)) then + if (GV%Boussinesq) then do k=1,nz ; do j=js,je ; do i=is,ie h(i,j,k) = GV%Z_to_H * dz(i,j,k) enddo ; enddo ; enddo @@ -616,6 +634,10 @@ subroutine dz_to_thickness_simple(dz, h, G, GV, US, halo_size, layer_mode) do k=1,nz ; do j=js,je ; do i=is,ie h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (US%Z_to_m * GV%m_to_H) * dz(i,j,k) + enddo ; enddo ; enddo endif end subroutine dz_to_thickness_simple From 597bbf119e83405c005b98f280c82224a9f535bb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Aug 2023 04:59:06 -0400 Subject: [PATCH 043/146] +*Non-Boussinesq revision of full_convection This commit revises full_convection to avoid any dependency on the Boussinesq reference density when in non-Boussinesq mode. Specifically, it changes the units of the Kddt_smooth argument to full_convection and its counterpart in smoothed_dRdT_dRdS to use units of [H Z ~> m2 or kg s-1], which becomes a mass based diffusivity when in non-Boussinesq mode. This change also uses vertical distances for internal calculations in smoothed_dRdT_dRdS, and includes a call to thickness_to_dz in the full_convection routine. This commit also revises the unit conversion of the (absurdly large) mixing length in unstable points in full_convection and of the (tiny) added smoothing distance used in the denominators of some expressions in smoothed_dRdT_dRdS to avoid division by zero with massless layers so that they are both based on the density used in rescaling input parameters (RHO_KV_CONVERT), and do not depend directly on the Boussinesq reference density (RHO_0). These parameters would have been set via get_param calls, but there is no control structure for full_convection parameters. All Boussinesq answers are bitwise identical, but non-Boussinesq answers are altered by the use of the layer specific volumes, rather than the Boussinesq reference density, to convert layer thicknesses into vertical distances. This commit includes a change to the units of an argument (Kddt_smooth) to a publicly visible interface (full_convection). --- .../vertical/MOM_full_convection.F90 | 44 +++++++++++-------- .../vertical/MOM_set_diffusivity.F90 | 2 +- 2 files changed, 27 insertions(+), 19 deletions(-) diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 344511bf29..a5fba3adc6 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -3,11 +3,12 @@ module MOM_full_convection ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs, EOS_domain +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs, EOS_domain implicit none ; private @@ -31,15 +32,16 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: S_adj !< Adjusted salinity [S ~> ppt]. real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). - real, intent(in) :: Kddt_smooth !< A smoothing vertical - !! diffusivity times a timestep [H2 ~> m2 or kg2 m-4]. + real, intent(in) :: Kddt_smooth !< A smoothing vertical diffusivity + !! times a timestep [H Z ~> m2 or kg m-1]. integer, intent(in) :: halo !< Halo width over which to compute ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & dRho_dT, & ! The derivative of density with temperature [R C-1 ~> kg m-3 degC-1] dRho_dS ! The derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. - real :: h_neglect, h0 ! A thickness that is so small it is usually lost + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. ! logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. real, dimension(SZI_(G),SZK0_(G)) :: & @@ -90,15 +92,17 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, if (.not.associated(tv%eqn_of_state)) return h_neglect = GV%H_subroundoff - mix_len = (1.0e20 * nz) * (G%max_depth * GV%Z_to_H) - h0 = 1.0e-16*sqrt(Kddt_smooth) + h_neglect + mix_len = (1.0e20 * nz) * (G%max_depth * US%Z_to_m * GV%m_to_H) do j=js,je mix(:,:) = 0.0 ; d_b(:,:) = 1.0 ! These would be Te_b(:,:) = tv%T(:,j,:), etc., but the values are not used Te_b(:,:) = 0.0 ; Se_b(:,:) = 0.0 - call smoothed_dRdT_dRdS(h, tv, Kddt_smooth, dRho_dT, dRho_dS, G, GV, US, j, p_surf, halo) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV, halo_size=halo) + + call smoothed_dRdT_dRdS(h, dz, tv, Kddt_smooth, dRho_dT, dRho_dS, G, GV, US, j, p_surf, halo) do i=is,ie do_i(i) = (G%mask2dT(i,j) > 0.0) @@ -306,14 +310,16 @@ end function is_unstable !> Returns the partial derivatives of locally referenced potential density with !! temperature and salinity after the properties have been smoothed with a small !! constant diffusivity. -subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, halo) +subroutine smoothed_dRdT_dRdS(h, dz, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Height change across layers [Z ~> m] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables - real, intent(in) :: Kddt !< A diffusivity times a time increment [H2 ~> m2 or kg2 m-4]. + real, intent(in) :: Kddt !< A diffusivity times a time increment [H Z ~> m2 or kg m-1]. real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: dR_dT !< Derivative of locally referenced !! potential density with temperature [R C-1 ~> kg m-3 degC-1] @@ -336,8 +342,9 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h real :: pres(SZI_(G)) ! Interface pressures [R L2 T-2 ~> Pa]. real :: T_EOS(SZI_(G)) ! Filtered and vertically averaged temperatures [C ~> degC] real :: S_EOS(SZI_(G)) ! Filtered and vertically averaged salinities [S ~> ppt] - real :: kap_dt_x2 ! The product of 2*kappa*dt [H2 ~> m2 or kg2 m-4]. - real :: h_neglect, h0 ! Negligible thicknesses to allow for zero thicknesses, + real :: kap_dt_x2 ! The product of 2*kappa*dt [H Z ~> m2 or kg m-1]. + real :: dz_neglect, h0 ! A negligible vertical distances [Z ~> m] + real :: h_neglect ! A negligible thickness to allow for zero thicknesses ! [H ~> m or kg m-2]. real :: h_tr ! The thickness at tracer points, plus h_neglect [H ~> m or kg m-2]. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -347,6 +354,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h nz = GV%ke h_neglect = GV%H_subroundoff + dz_neglect = GV%dz_subroundoff kap_dt_x2 = 2.0*Kddt if (Kddt <= 0.0) then @@ -354,9 +362,9 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h T_f(i,k) = tv%T(i,j,k) ; S_f(i,k) = tv%S(i,j,k) enddo ; enddo else - h0 = 1.0e-16*sqrt(Kddt) + h_neglect + h0 = 1.0e-16*sqrt(GV%H_to_m*US%m_to_Z*Kddt) + dz_neglect do i=is,ie - mix(i,2) = kap_dt_x2 / ((h(i,j,1)+h(i,j,2)) + h0) + mix(i,2) = kap_dt_x2 / ((dz(i,1)+dz(i,2)) + h0) h_tr = h(i,j,1) + h_neglect b1(i) = 1.0 / (h_tr + mix(i,2)) @@ -365,7 +373,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h S_f(i,1) = (b1(i)*h_tr)*tv%S(i,j,1) enddo do k=2,nz-1 ; do i=is,ie - mix(i,K+1) = kap_dt_x2 / ((h(i,j,k)+h(i,j,k+1)) + h0) + mix(i,K+1) = kap_dt_x2 / ((dz(i,k)+dz(i,k+1)) + h0) c1(i,k) = mix(i,K) * b1(i) h_tr = h(i,j,k) + h_neglect diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index b3b49e0772..32553de3d1 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -344,7 +344,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then call full_convection(G, GV, US, h, tv, T_f, S_f, fluxes%p_surf, & - GV%Z_to_H*kappa_dt_fill, halo=1) + kappa_dt_fill, halo=1) call calc_kappa_shear_vertex(u, v, h, T_f, S_f, tv, fluxes%p_surf, visc%Kd_shear, & visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) From 3ce1368c64a60f634ec11222392fd50e94132ecb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Aug 2023 23:11:56 -0400 Subject: [PATCH 044/146] +*Non-Boussinesq revision of MOM_vertvisc.F90 Revised the code in MOM_vertvisc.F90 to work internally with thickness-based units for the viscous coupling between layers, which eliminates any dependence on the value of GV%Rho_0 in non-Boussinesq mode. Various kinematic viscosities are replaced with dynamic viscosities in non-Boussinesq configurations, including revising the scaled units of the viscosities to [H Z T-1 ~> m2 s-1 or Pa s]. This commit also modifies the code to explicitly use vertical distances rather than thicknesses when calculating the vertical viscous coupling coefficients in vertvisc_coef and find_coupling_coef. This commit changes the units of numerous variables to use thickness, vertical distance, dynamic viscosity or other related units, including: - 14 elements in the vertvisc_CS type - 6 arguments to the private routine find_coupling_coef - 2 arguments to the private routine find_coupling_coef_gl90 - 1 arguments ("a") to the public routine write_u_accel - 1 arguments ("a") to the public routine write_v_accel - 1 internal variable in vertvisc - 1 internal variable in vertvisc_remnant - 23 internal variables in vertvisc_coef, - 7+4+4+3 internal variables in find_coupling_coef, - 1 internal variable in find_coupling_coef_gl90 Local variables that are no longer needed were eliminated in vertvisc and vertvisc_remnant, while 2 new local variables were added to find_coupling_coef and 6 new local variables were added to vertvisc_coef. In 6 places the Boussinesq reference density was replaced with GV%H_to_RZ, which is equivalent to the reference density in Boussinesq mode, but scales to 1 in non-Boussinesq mode. The previous dimensional rescaling factor for KD_GL90 was incorrect (and inconsistent with the correct scaling factor used when reading in the analagous spatially varying kappa_gl90_2d); this has been corrected in this commit. A total of 59 GV%H_to_Z or GV%Z_to_H unit conversion factors or references to GV%Rho_0 were eliminated with these changes, and in non-Boussinesq mode there is no longer any dependence on the Boussinesq reference density. Replaced the forces argument to find_coupling_coef with an array of the friction velocities and use find_ustar to set them. When in non-Boussinesq mode, this has the effect of using forces%tau_mag and tv%SpV_avg instead of forces%ustar and GV%Rho0 when interpolating the friction velocity and stress magnitude in find_coupling_coef. Revised units used to set the GL90 viscosities and rescale to convert diagnostics of the vertical viscosities in the MOM_vert_friction module, so that they do not depend on RHO_0 when in non-Boussinesq mode. To accomodate this change in vertvisc, the units of the "a" arguments to write_u_accel and write_v_accel were also changed to use thickness-based arguments. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode. In non-Boussinesq mode, the answers are changed by the replacement of the Boussinesq reference density by expressions using the layer-averaged specific volumes. This commit changes the units of 2 arguments in public (diagnostic) subroutine interfaces. --- src/diagnostics/MOM_PointAccel.F90 | 14 +- .../vertical/MOM_vert_friction.F90 | 684 ++++++++++-------- 2 files changed, 403 insertions(+), 295 deletions(-) diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index d53b2e6636..e9c1092ed7 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -83,7 +83,8 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1] real, optional, intent(in) :: str !< The surface wind stress [R L Z T-2 ~> Pa] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z T-1 ~> m s-1]. + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc + !! [H T-1 ~> m s-1 or Pa s m-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc [H ~> m or kg m-2]. @@ -223,8 +224,8 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st (vel_scale*ADp%du_other(I,j,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",ES10.3," ")', advance='no') US%Z_to_m*a(I,j,ks)*dt - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (US%Z_to_m*a(I,j,K)*dt) ; enddo + write(file,'(/,"a: ",ES10.3," ")', advance='no') h_scale*a(I,j,ks)*dt + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (h_scale*a(I,j,K)*dt) ; enddo endif if (present(hv)) then write(file,'(/,"hvel: ")', advance='no') @@ -422,7 +423,8 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1] real, optional, intent(in) :: str !< The surface wind stress [R L Z T-2 ~> Pa] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & - optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z T-1 ~> m s-1]. + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc + !! [H T-1 ~> m s-1 or Pa s m-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc [H ~> m or kg m-2]. @@ -566,8 +568,8 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st (vel_scale*ADp%dv_other(i,J,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",ES10.3," ")', advance='no') US%Z_to_m*a(i,J,ks)*dt - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (US%Z_to_m*a(i,J,K)*dt) ; enddo + write(file,'(/,"a: ",ES10.3," ")', advance='no') h_scale*a(i,J,ks)*dt + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (h_scale*a(i,J,K)*dt) ; enddo endif if (present(hv)) then write(file,'(/,"hvel: ")', advance='no') diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 133d72fa17..b0b47bf2b1 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -12,7 +12,7 @@ module MOM_vert_friction use MOM_debugging, only : uvchksum, hchksum use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : mech_forcing +use MOM_forcing_type, only : mech_forcing, find_ustar use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type use MOM_io, only : MOM_read_data, slasher @@ -28,6 +28,7 @@ module MOM_vert_friction use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS use MOM_lateral_mixing_coeffs, only : VarMix_CS + implicit none ; private #include @@ -44,18 +45,18 @@ module MOM_vert_friction !> The control structure with parameters and memory for the MOM_vert_friction module type, public :: vertvisc_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: Hmix !< The mixed layer thickness in thickness units [H ~> m or kg m-2]. + real :: Hmix !< The mixed layer thickness [Z ~> m]. real :: Hmix_stress !< The mixed layer thickness over which the wind !! stress is applied with direct_stress [H ~> m or kg m-2]. - real :: Kvml_invZ2 !< The extra vertical viscosity scale in [Z2 T-1 ~> m2 s-1] in a + real :: Kvml_invZ2 !< The extra vertical viscosity scale in [H Z T-1 ~> m2 s-1 or Pa s] in a !! surface mixed layer with a characteristic thickness given by Hmix, !! and scaling proportional to (Hmix/z)^2, where z is the distance !! from the surface; this can get very large with thin layers. - real :: Kv !< The interior vertical viscosity [Z2 T-1 ~> m2 s-1]. - real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. - real :: Hbbl_gl90 !< The static bottom boundary layer thickness used for GL90 [H ~> m or kg m-2]. + real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + real :: Hbbl !< The static bottom boundary layer thickness [Z ~> m]. + real :: Hbbl_gl90 !< The static bottom boundary layer thickness used for GL90 [Z ~> m]. real :: Kv_extra_bbl !< An extra vertical viscosity in the bottom boundary layer of thickness - !! Hbbl when there is not a bottom drag law in use [Z2 T-1 ~> m2 s-1]. + !! Hbbl when there is not a bottom drag law in use [H Z T-1 ~> m2 s-1 or Pa s]. real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] logical :: use_GL90_in_SSW !< If true, use the GL90 parameterization in stacked shallow water mode (SSW). @@ -65,12 +66,12 @@ module MOM_vert_friction logical :: use_GL90_N2 !< If true, use GL90 vertical viscosity coefficient that is depth-independent; !! this corresponds to a kappa_GM that scales as N^2 with depth. real :: kappa_gl90 !< The scalar diffusivity used in the GL90 vertical viscosity scheme - !! [L2 T-1 ~> m2 s-1] + !! [L2 H Z-1 T-1 ~> m2 s-1 or Pa s] logical :: read_kappa_gl90 !< If true, read a file containing the spatially varying kappa_gl90 real :: alpha_gl90 !< Coefficient used to compute a depth-independent GL90 vertical !! viscosity via Kv_gl90 = alpha_gl90 * f^2. Note that the implied !! Kv_gl90 corresponds to a kappa_gl90 that scales as N^2 with depth. - !! [L2 T ~> m2 s] + !! [H Z T ~> m2 s or kg s m-1] real :: maxvel !< Velocity components greater than maxvel are truncated [L T-1 ~> m s-1]. real :: vel_underflow !< Velocity components smaller than vel_underflow !! are set to 0 [L T-1 ~> m s-1]. @@ -90,21 +91,21 @@ module MOM_vert_friction type(time_type) :: rampStartTime !< The time at which the ramping of CFL_trunc starts real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & - a_u !< The u-drag coefficient across an interface [Z T-1 ~> m s-1]. + a_u !< The u-drag coefficient across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & - a_u_gl90 !< The u-drag coefficient associated with GL90 across an interface [Z T-1 ~> m s-1]. + a_u_gl90 !< The u-drag coefficient associated with GL90 across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & h_u !< The effective layer thickness at u-points [H ~> m or kg m-2]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & - a_v !< The v-drag coefficient across an interface [Z T-1 ~> m s-1]. + a_v !< The v-drag coefficient across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & - a_v_gl90 !< The v-drag coefficient associated with GL90 across an interface [Z T-1 ~> m s-1]. + a_v_gl90 !< The v-drag coefficient associated with GL90 across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & h_v !< The effective layer thickness at v-points [H ~> m or kg m-2]. real, pointer, dimension(:,:) :: a1_shelf_u => NULL() !< The u-momentum coupling coefficient under - !! ice shelves [Z T-1 ~> m s-1]. Retained to determine stress under shelves. + !! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. Retained to determine stress under shelves. real, pointer, dimension(:,:) :: a1_shelf_v => NULL() !< The v-momentum coupling coefficient under - !! ice shelves [Z T-1 ~> m s-1]. Retained to determine stress under shelves. + !! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. Retained to determine stress under shelves. logical :: split !< If true, use the split time stepping scheme. logical :: bottomdraglaw !< If true, the bottom stress is calculated with a @@ -158,7 +159,7 @@ module MOM_vert_friction type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. - real, allocatable, dimension(:,:) :: kappa_gl90_2d !< 2D kappa_gl90 at h-points [L2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:) :: kappa_gl90_2d !< 2D kappa_gl90 at h-points [L2 H Z-1 T-1 ~> m2 s-1 or Pa s] !>@{ Diagnostic identifiers integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_du_dt_visc_gl90 = -1, id_dv_dt_visc_gl90 = -1 @@ -206,8 +207,8 @@ module MOM_vert_friction subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, VarMix, work_on_u) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: hvel !< Layer thickness used at a velocity - !! grid point [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: hvel !< Distance between interfaces + !! at velocity points [Z ~> m] logical, dimension(SZIB_(G)), intent(in) :: do_i !< If true, determine coupling coefficient !! for a column real, dimension(SZIB_(G),SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the @@ -215,7 +216,7 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va !! boundary layer thickness [nondim] real, dimension(SZIB_(G),SZK_(GV)+1), intent(inout) :: a_cpl_gl90 !< Coupling coefficient associated !! with GL90 across interfaces; is not - !! included in a_cpl [Z T-1 ~> m s-1]. + !! included in a_cpl [H T-1 ~> m s-1 or Pa s m-1]. integer, intent(in) :: j !< j-index to find coupling coefficient for type(vertvisc_cs), pointer :: CS !< Vertical viscosity control structure type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients @@ -223,23 +224,19 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va !! otherwise they are v-points. ! local variables - logical :: kdgl90_use_ebt_struct - integer :: i, k, is, ie, nz, Isq, Ieq - real :: f2 !< Squared Coriolis parameter at a - !! velocity grid point [T-2 ~> s-2]. - real :: h_neglect ! A thickness that is so small - !! it is usually lost in roundoff error - !! and can be neglected [H ~> m or kg m-2]. - real :: botfn ! A function that is 1 at the bottom - !! and small far from it [nondim] - real :: z2 ! The distance from the bottom, - !! normalized by Hbbl_gl90 [nondim] + logical :: kdgl90_use_ebt_struct + integer :: i, k, is, ie, nz, Isq, Ieq + real :: f2 !< Squared Coriolis parameter at a velocity grid point [T-2 ~> s-2]. + real :: h_neglect ! A vertical distance that is so small it is usually lost in roundoff error + ! and can be neglected [Z ~> m]. + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] + real :: z2 ! The distance from the bottom, normalized by Hbbl_gl90 [nondim] is = G%isc ; ie = G%iec Isq = G%IscB ; Ieq = G%IecB nz = GV%ke - h_neglect = GV%H_subroundoff + h_neglect = GV%dZ_subroundoff kdgl90_use_ebt_struct = .false. if (VarMix%use_variable_mixing) then kdgl90_use_ebt_struct = VarMix%kdgl90_use_ebt_struct @@ -348,7 +345,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [Z T-1 ~> m s-1]. + real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: Hmix ! The mixed layer thickness over which stress @@ -356,8 +353,6 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: I_Hmix ! The inverse of Hmix [H-1 ~> m-1 or m2 kg-1]. real :: Idt ! The inverse of the time step [T-1 ~> s-1]. real :: dt_Rho0 ! The time step divided by the mean density [T H Z-1 R-1 ~> s m3 kg-1 or s]. - real :: dt_Z_to_H ! The time step times the conversion from Z to the - ! units of thickness - [T H Z-1 ~> s or s kg m-3]. 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]. @@ -402,7 +397,6 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & I_Hmix = 1.0 / Hmix endif dt_Rho0 = dt / GV%H_to_RZ - dt_Z_to_H = dt*GV%Z_to_H h_neglect = GV%H_subroundoff Idt = 1.0 / dt @@ -464,7 +458,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; endif ! direct_stress if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = GV%H_to_Z*visc%Ray_u(I,j,k) + Ray(I,k) = visc%Ray_u(I,j,k) enddo ; enddo ; endif ! perform forward elimination on the tridiagonal system @@ -473,9 +467,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! and the superdiagonal as c_k. The right-hand side terms are d_k. ! ! ignoring the Rayleigh drag contribution, - ! we have a_k = -dt_Z_to_H * a_u(k) - ! b_k = h_u(k) + dt_Z_to_H * (a_u(k) + a_u(k+1)) - ! c_k = -dt_Z_to_H * a_u(k+1) + ! we have a_k = -dt * a_u(k) + ! b_k = h_u(k) + dt * (a_u(k) + a_u(k+1)) + ! c_k = -dt * a_u(k+1) ! ! for forward elimination, we want to: ! calculate c'_k = - c_k / (b_k + a_k c'_(k-1)) @@ -494,23 +488,23 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! and the right-hand-side is destructively updated to be d'_k ! do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt_Z_to_H * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u(I,j,2)) + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,1) + CS%a_u(I,j,1)) + b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) d1(I) = b_denom_1 * b1(I) u(I,j,1) = b1(I) * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I)) if (associated(ADp%du_dt_str)) & ADp%du_dt_str(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I)*Idt) endif ; enddo do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_Z_to_H * CS%a_u(I,j,K) * b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u(I,j,K+1)) + c1(I,k) = dt * CS%a_u(I,j,K) * b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) d1(I) = b_denom_1 * b1(I) u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + & - dt_Z_to_H * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) + dt * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) if (associated(ADp%du_dt_str)) & ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) + & - dt_Z_to_H * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I) + dt * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I) endif ; enddo ; enddo ! back substitute to solve for the new velocities @@ -534,17 +528,17 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (associated(ADp%du_dt_visc_gl90)) then do I=Isq,Ieq ; if (do_i(I)) then b_denom_1 = CS%h_u(I,j,1) ! CS%a_u_gl90(I,j,1) is zero - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u_gl90(I,j,2)) + b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u_gl90(I,j,2)) d1(I) = b_denom_1 * b1(I) ADp%du_dt_visc_gl90(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1)) endif ; enddo do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_Z_to_H * CS%a_u_gl90(I,j,K) * b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (CS%a_u_gl90(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u_gl90(I,j,K+1)) + c1(I,k) = dt * CS%a_u_gl90(I,j,K) * b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt * (CS%a_u_gl90(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,K+1)) d1(I) = b_denom_1 * b1(I) ADp%du_dt_visc_gl90(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_visc_gl90(I,j,k) + & - dt_Z_to_H * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1(I) + dt * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1(I) endif ; enddo ; enddo ! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90 do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then @@ -573,15 +567,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; enddo ; endif if (allocated(visc%taux_shelf)) then ; do I=Isq,Ieq - visc%taux_shelf(I,j) = -GV%Rho0*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? + visc%taux_shelf(I,j) = -GV%H_to_RZ*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? enddo ; endif if (PRESENT(taux_bot)) then do I=Isq,Ieq - taux_bot(I,j) = GV%Rho0 * (u(I,j,nz)*CS%a_u(I,j,nz+1)) + taux_bot(I,j) = GV%H_to_RZ * (u(I,j,nz)*CS%a_u(I,j,nz+1)) enddo if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - taux_bot(I,j) = taux_bot(I,j) + GV%Rho0 * (Ray(I,k)*u(I,j,k)) + taux_bot(I,j) = taux_bot(I,j) + GV%H_to_RZ * (Ray(I,k)*u(I,j,k)) enddo ; enddo ; endif endif @@ -636,26 +630,26 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; endif ! direct_stress if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = GV%H_to_Z*visc%Ray_v(i,J,k) + Ray(i,k) = visc%Ray_v(i,J,k) enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt_Z_to_H * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v(i,J,2)) + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,1) + CS%a_v(i,J,1)) + b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) d1(i) = b_denom_1 * b1(i) v(i,J,1) = b1(i) * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i)) if (associated(ADp%dv_dt_str)) & ADp%dv_dt_str(i,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i)*Idt) endif ; enddo do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_Z_to_H * CS%a_v(i,J,K) * b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v(i,J,K+1)) + c1(i,k) = dt * CS%a_v(i,J,K) * b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) d1(i) = b_denom_1 * b1(i) - v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt_Z_to_H * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) + v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) if (associated(ADp%dv_dt_str)) & ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) + & - dt_Z_to_H * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i) + dt * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i) endif ; enddo ; enddo do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then v(i,J,k) = v(i,J,k) + c1(i,k+1) * v(i,J,k+1) @@ -676,17 +670,17 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (associated(ADp%dv_dt_visc_gl90)) then do i=is,ie ; if (do_i(i)) then b_denom_1 = CS%h_v(i,J,1) ! CS%a_v_gl90(i,J,1) is zero - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v_gl90(i,J,2)) + b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v_gl90(i,J,2)) d1(i) = b_denom_1 * b1(i) ADp%dv_dt_visc_gl90(I,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1)) endif ; enddo do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_Z_to_H * CS%a_v_gl90(i,J,K) * b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (CS%a_v_gl90(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v_gl90(i,J,K+1)) + c1(i,k) = dt * CS%a_v_gl90(i,J,K) * b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt * (CS%a_v_gl90(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v_gl90(i,J,K+1)) d1(i) = b_denom_1 * b1(i) ADp%dv_dt_visc_gl90(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_visc_gl90(i,J,k) + & - dt_Z_to_H * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1(i) + dt * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1(i) endif ; enddo ; enddo ! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90 do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then @@ -716,15 +710,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; enddo ; endif if (allocated(visc%tauy_shelf)) then ; do i=is,ie - visc%tauy_shelf(i,J) = -GV%Rho0*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? + visc%tauy_shelf(i,J) = -GV%H_to_RZ*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? enddo ; endif if (present(tauy_bot)) then do i=is,ie - tauy_bot(i,J) = GV%Rho0 * (v(i,J,nz)*CS%a_v(i,J,nz+1)) + tauy_bot(i,J) = GV%H_to_RZ * (v(i,J,nz)*CS%a_v(i,J,nz+1)) enddo if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - tauy_bot(i,J) = tauy_bot(i,J) + GV%Rho0 * (Ray(i,k)*v(i,J,k)) + tauy_bot(i,J) = tauy_bot(i,J) + GV%H_to_RZ * (Ray(i,k)*v(i,J,k)) enddo ; enddo ; endif endif @@ -851,10 +845,8 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [Z T-1 ~> m s-1]. + real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. - real :: dt_Z_to_H ! The time step times the conversion from Z to the - ! units of thickness [T H Z-1 ~> s or s kg m-3]. logical :: do_i(SZIB_(G)) integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz @@ -867,8 +859,6 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remant): "// & "Module must be initialized before it is used.") - dt_Z_to_H = dt*GV%Z_to_H - do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. @@ -877,21 +867,21 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = GV%H_to_Z*visc%Ray_u(I,j,k) + Ray(I,k) = visc%Ray_u(I,j,k) enddo ; enddo ; endif do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt_Z_to_H * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u(I,j,2)) + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,1) + CS%a_u(I,j,1)) + b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) d1(I) = b_denom_1 * b1(I) visc_rem_u(I,j,1) = b1(I) * CS%h_u(I,j,1) endif ; enddo do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_Z_to_H * CS%a_u(I,j,K)*b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u(I,j,K+1)) + c1(I,k) = dt * CS%a_u(I,j,K)*b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) d1(I) = b_denom_1 * b1(I) - visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt_Z_to_H * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I) + visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I) endif ; enddo ; enddo do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(I,k+1)*visc_rem_u(I,j,k+1) @@ -906,21 +896,21 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = GV%H_to_Z*visc%Ray_v(i,J,k) + Ray(i,k) = visc%Ray_v(i,J,k) enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt_Z_to_H * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v(i,J,2)) + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,1) + CS%a_v(i,J,1)) + b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) d1(i) = b_denom_1 * b1(i) visc_rem_v(i,J,1) = b1(i) * CS%h_v(i,J,1) endif ; enddo do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_Z_to_H * CS%a_v(i,J,K)*b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v(i,J,K+1)) + c1(i,k) = dt * CS%a_v(i,J,K)*b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) d1(i) = b_denom_1 * b1(i) - visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt_Z_to_H * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i) + visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i) endif ; enddo ; enddo do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(i,k+1)*visc_rem_v(i,J,k+1) @@ -970,52 +960,65 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, h_arith, & ! The arithmetic mean thickness [H ~> m or kg m-2]. h_delta, & ! The lateral difference of thickness [H ~> m or kg m-2]. hvel, & ! hvel is the thickness used at a velocity grid point [H ~> m or kg m-2]. - hvel_shelf ! The equivalent of hvel under shelves [H ~> m or kg m-2]. + hvel_shelf, & ! The equivalent of hvel under shelves [H ~> m or kg m-2]. + dz_harm, & ! Harmonic mean of the vertical distances around a velocity grid point, + ! given by 2*(h+ * h-)/(h+ + h-) [Z ~> m]. + dz_arith, & ! The arithmetic mean of the vertical distances around a velocity grid point [Z ~> m] + dz_vel, & ! The vertical distance between interfaces used at a velocity grid point [Z ~> m]. + dz_vel_shelf ! The equivalent of dz_vel under shelves [Z ~> m]. real, dimension(SZIB_(G),SZK_(GV)+1) :: & - a_cpl, & ! The drag coefficients across interfaces [Z T-1 ~> m s-1]. a_cpl times + a_cpl, & ! The drag coefficients across interfaces [H T-1 ~> m s-1 or Pa s m-1]. a_cpl times ! the velocity difference gives the stress across an interface. - a_cpl_gl90, & ! The drag coefficients across interfaces associated with GL90 [Z T-1 ~> m s-1]. + a_cpl_gl90, & ! The drag coefficients across interfaces associated with GL90 [H T-1 ~> m s-1 or Pa s m-1]. ! a_cpl_gl90 times the velocity difference gives the GL90 stress across an interface. ! a_cpl_gl90 is part of a_cpl. a_shelf, & ! The drag coefficients across interfaces in water columns under - ! ice shelves [Z T-1 ~> m s-1]. + ! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. z_i, & ! An estimate of each interface's height above the bottom, ! normalized by the bottom boundary layer thickness [nondim] z_i_gl90 ! An estimate of each interface's height above the bottom, ! normalized by the GL90 bottom boundary layer thickness [nondim] real, dimension(SZIB_(G)) :: & - kv_bbl, & ! The bottom boundary layer viscosity [Z2 T-1 ~> m2 s-1]. - bbl_thick, & ! The bottom boundary layer thickness [H ~> m or kg m-2]. - I_Hbbl, & ! The inverse of the bottom boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. + kv_bbl, & ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + bbl_thick, & ! The bottom boundary layer thickness [Z ~> m]. + I_Hbbl, & ! The inverse of the bottom boundary layer thickness [Z-1 ~> m-1]. I_Hbbl_gl90, &! The inverse of the bottom boundary layer thickness used for the GL90 scheme - ! [H-1 ~> m-1 or m2 kg-1]. - I_Htbl, & ! The inverse of the top boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. - zcol1, & ! The height of the interfaces to the south of a v-point [H ~> m or kg m-2]. - zcol2, & ! The height of the interfaces to the north of a v-point [H ~> m or kg m-2]. - Ztop_min, & ! The deeper of the two adjacent surface heights [H ~> m or kg m-2]. - Dmin, & ! The shallower of the two adjacent bottom depths converted to - ! thickness units [H ~> m or kg m-2]. + ! [Z-1 ~> m-1]. + I_HTbl, & ! The inverse of the top boundary layer thickness [Z-1 ~> m-1]. + zcol1, & ! The height of the interfaces to the south of a v-point [Z ~> m]. + zcol2, & ! The height of the interfaces to the north of a v-point [Z ~> m]. + Ztop_min, & ! The deeper of the two adjacent surface heights [Z ~> m]. + Dmin, & ! The shallower of the two adjacent bottom depths [Z ~> m]. zh, & ! An estimate of the interface's distance from the bottom - ! based on harmonic mean thicknesses [H ~> m or kg m-2]. - h_ml ! The mixed layer depth [H ~> m or kg m-2]. - real, allocatable, dimension(:,:) :: hML_u ! Diagnostic of the mixed layer depth at u points [H ~> m or kg m-2]. - real, allocatable, dimension(:,:) :: hML_v ! Diagnostic of the mixed layer depth at v points [H ~> m or kg m-2]. - real, allocatable, dimension(:,:,:) :: Kv_u !< Total vertical viscosity at u-points [Z2 T-1 ~> m2 s-1]. - real, allocatable, dimension(:,:,:) :: Kv_v !< Total vertical viscosity at v-points [Z2 T-1 ~> m2 s-1]. - real, allocatable, dimension(:,:,:) :: Kv_gl90_u !< GL90 vertical viscosity at u-points [Z2 T-1 ~> m2 s-1]. - real, allocatable, dimension(:,:,:) :: Kv_gl90_v !< GL90 vertical viscosity at v-points [Z2 T-1 ~> m2 s-1]. - real :: zcol(SZI_(G)) ! The height of an interface at h-points [H ~> m or kg m-2]. + ! based on harmonic mean thicknesses [Z ~> m]. + h_ml ! The mixed layer depth [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Ustar_2d ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: hML_u ! Diagnostic of the mixed layer depth at u points [Z ~> m]. + real, allocatable, dimension(:,:) :: hML_v ! Diagnostic of the mixed layer depth at v points [Z ~> m]. + real, allocatable, dimension(:,:,:) :: Kv_u ! Total vertical viscosity at u-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_v ! Total vertical viscosity at v-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_u ! GL90 vertical viscosity at u-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_v ! GL90 vertical viscosity at v-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real :: zcol(SZI_(G)) ! The height of an interface at h-points [Z ~> m]. real :: botfn ! A function which goes from 1 at the bottom to 0 much more ! than Hbbl into the interior [nondim]. real :: topfn ! A function which goes from 1 at the top to 0 much more ! than Htbl into the interior [nondim]. real :: z2 ! The distance from the bottom, normalized by Hbbl [nondim] real :: z2_wt ! A nondimensional (0-1) weight used when calculating z2 [nondim]. - real :: z_clear ! The clearance of an interface above the surrounding topography [H ~> m or kg m-2]. + real :: z_clear ! The clearance of an interface above the surrounding topography [Z ~> m]. real :: a_cpl_max ! The maximum drag coefficient across interfaces, set so that it will be - ! representable as a 32-bit float in MKS units [Z T-1 ~> m s-1] + ! representable as a 32-bit float in MKS units [H T-1 ~> m s-1 or Pa s m-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]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: I_valBL ! The inverse of a scaling factor determining when water is ! still within the boundary layer, as determined by the sum @@ -1036,10 +1039,11 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, 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) + dz_neglect = GV%dZ_subroundoff + a_cpl_max = 1.0e37 * GV%m_to_H * US%T_to_s + I_Hbbl(:) = 1.0 / (CS%Hbbl + dz_neglect) if (CS%use_GL90_in_SSW) then - I_Hbbl_gl90 = 1.0 / (CS%Hbbl_gl90 + h_neglect) + I_Hbbl_gl90(:) = 1.0 / (CS%Hbbl_gl90 + dz_neglect) endif I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val @@ -1063,15 +1067,18 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, allocate(CS%a1_shelf_v(G%isd:G%ied,G%JsdB:G%JedB), source=0.0) endif - !$OMP 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,a_cpl_max) & - !$OMP firstprivate(i_hbbl) + call find_ustar(forces, tv, Ustar_2d, G, GV, US, halo=1) + + !$OMP parallel do default(private) shared(G,GV,US,CS,tv,visc,OBC,Isq,Ieq,nz,u,h,dz,forces, & + !$OMP Ustar_2d,h_neglect,dz_neglect,dt,I_valBL,hML_u,Kv_u, & + !$OMP a_cpl_max,I_Hbbl_gl90,Kv_gl90_u) & + !$OMP firstprivate(I_Hbbl) do j=G%Jsc,G%Jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do I=Isq,Ieq - kv_bbl(I) = GV%H_to_Z*visc%Kv_bbl_u(I,j) - bbl_thick(I) = visc%bbl_thick_u(I,j) * GV%Z_to_H + h_neglect + kv_bbl(I) = visc%Kv_bbl_u(I,j) + bbl_thick(I) = visc%bbl_thick_u(I,j) + dz_neglect if (do_i(I)) I_Hbbl(I) = 1.0 / bbl_thick(I) enddo ; endif @@ -1079,9 +1086,11 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, h_harm(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / (h(i,j,k)+h(i+1,j,k)+h_neglect) h_arith(I,k) = 0.5*(h(i+1,j,k)+h(i,j,k)) h_delta(I,k) = h(i+1,j,k) - h(i,j,k) + dz_harm(I,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / (dz(i,j,k)+dz(i+1,j,k)+dz_neglect) + dz_arith(I,k) = 0.5*(dz(i+1,j,k)+dz(i,j,k)) endif ; enddo ; enddo do I=Isq,Ieq - Dmin(I) = min(G%bathyT(i,j), G%bathyT(i+1,j)) * GV%Z_to_H + Dmin(I) = min(G%bathyT(i,j), G%bathyT(i+1,j)) zi_dir(I) = 0 enddo @@ -1089,19 +1098,25 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then do I=Isq,Ieq ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do k=1,nz ; h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(I,k) = 0. ; enddo - Dmin(I) = G%bathyT(i,j) * GV%Z_to_H + do k=1,nz + h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(I,k) = 0. + dz_harm(I,k) = dz(i,j,k) ; dz_arith(I,k) = dz(i,j,k) + enddo + Dmin(I) = G%bathyT(i,j) zi_dir(I) = -1 elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do k=1,nz ; h_harm(I,k) = h(i+1,j,k) ; h_arith(I,k) = h(i+1,j,k) ; h_delta(I,k) = 0. ; enddo - Dmin(I) = G%bathyT(i+1,j) * GV%Z_to_H + do k=1,nz + h_harm(I,k) = h(i+1,j,k) ; h_arith(I,k) = h(i+1,j,k) ; h_delta(I,k) = 0. + dz_harm(I,k) = dz(i+1,j,k) ; dz_arith(I,k) = dz(i+1,j,k) + enddo + Dmin(I) = G%bathyT(i+1,j) zi_dir(I) = 1 endif endif ; enddo endif ; endif ! The following block calculates the thicknesses at velocity -! grid points for the vertical viscosity (hvel). Near the +! grid points for the vertical viscosity (hvel and dz_vel). Near the ! bottom an upwind biased thickness is used to control the effect ! of spurious Montgomery potential gradients at the bottom where ! nearly massless layers layers ride over the topography. @@ -1109,19 +1124,21 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do I=Isq,Ieq ; z_i(I,nz+1) = 0.0 ; enddo do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then hvel(I,k) = h_harm(I,k) + dz_vel(I,k) = dz_harm(I,k) if (u(I,j,k) * h_delta(I,k) < 0) then z2 = z_i(I,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) hvel(I,k) = (1.0-botfn)*h_harm(I,k) + botfn*h_arith(I,k) + dz_vel(I,k) = (1.0-botfn)*dz_harm(I,k) + botfn*dz_arith(I,k) endif - z_i(I,k) = z_i(I,k+1) + h_harm(I,k)*I_Hbbl(I) + z_i(I,k) = z_i(I,k+1) + dz_harm(I,k)*I_Hbbl(I) endif ; enddo ; enddo ! i & k loops else ! Not harmonic_visc do I=Isq,Ieq ; zh(I) = 0.0 ; z_i(I,nz+1) = 0.0 ; enddo - do i=Isq,Ieq+1 ; zcol(i) = -G%bathyT(i,j) * GV%Z_to_H ; enddo + do i=Isq,Ieq+1 ; zcol(i) = -G%bathyT(i,j) ; enddo do k=nz,1,-1 - do i=Isq,Ieq+1 ; zcol(i) = zcol(i) + h(i,j,k) ; enddo + do i=Isq,Ieq+1 ; zcol(i) = zcol(i) + dz(i,j,k) ; enddo do I=Isq,Ieq ; if (do_i(I)) then - zh(I) = zh(I) + h_harm(I,k) + zh(I) = zh(I) + dz_harm(I,k) z_clear = max(zcol(i),zcol(i+1)) + Dmin(I) if (zi_dir(I) < 0) z_clear = zcol(i) + Dmin(I) @@ -1130,15 +1147,18 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, z_i(I,k) = max(zh(I), z_clear) * I_Hbbl(I) hvel(I,k) = h_arith(I,k) + dz_vel(I,k) = dz_arith(I,k) if (u(I,j,k) * h_delta(I,k) > 0) then if (zh(I) * I_Hbbl(I) < CS%harm_BL_val) then hvel(I,k) = h_harm(I,k) + dz_vel(I,k) = dz_harm(I,k) else z2_wt = 1.0 ; if (zh(I) * I_Hbbl(I) < 2.0*CS%harm_BL_val) & z2_wt = max(0.0, min(1.0, zh(I) * I_Hbbl(I) * I_valBL - 1.0)) z2 = z2_wt * (max(zh(I), z_clear) * I_Hbbl(I)) botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) hvel(I,k) = (1.0-botfn)*h_arith(I,k) + botfn*h_harm(I,k) + dz_vel(I,k) = (1.0-botfn)*dz_arith(I,k) + botfn*dz_harm(I,k) endif endif @@ -1146,8 +1166,8 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, enddo ! k loop endif - call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u=.true., OBC=OBC) + call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.true., OBC=OBC) a_cpl_gl90(:,:) = 0.0 if (CS%use_GL90_in_SSW) then ! The following block calculates the normalized height above the GL90 @@ -1160,9 +1180,9 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, ! over topography, small enough to not contaminate the interior. do I=Isq,Ieq ; z_i_gl90(I,nz+1) = 0.0 ; enddo do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - z_i_gl90(I,k) = z_i_gl90(I,k+1) + h_harm(I,k)*I_Hbbl_gl90(I) + z_i_gl90(I,k) = z_i_gl90(I,k+1) + dz_harm(I,k)*I_Hbbl_gl90(I) endif ; enddo ; enddo ! i & k loops - call find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.true.) + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.true.) endif if (allocated(hML_u)) then @@ -1178,35 +1198,39 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, enddo if (do_any_shelf) then if (CS%harmonic_visc) then - do k=1,nz ; do I=Isq,Ieq ; hvel_shelf(I,k) = hvel(I,k) ; enddo ; enddo + do k=1,nz ; do I=Isq,Ieq + hvel_shelf(I,k) = hvel(I,k) ; dz_vel_shelf(I,k) = dz_vel(I,k) + enddo ; enddo else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. do I=Isq,Ieq ; if (do_i_shelf(I)) then zh(I) = 0.0 ; Ztop_min(I) = min(zcol(i), zcol(i+1)) - I_HTbl(I) = 1.0 / (visc%tbl_thick_shelf_u(I,j)*GV%Z_to_H + h_neglect) + I_HTbl(I) = 1.0 / (visc%tbl_thick_shelf_u(I,j) + dz_neglect) endif ; enddo do k=1,nz - do i=Isq,Ieq+1 ; zcol(i) = zcol(i) - h(i,j,k) ; enddo + do i=Isq,Ieq+1 ; zcol(i) = zcol(i) - dz(i,j,k) ; enddo do I=Isq,Ieq ; if (do_i_shelf(I)) then - zh(I) = zh(I) + h_harm(I,k) + zh(I) = zh(I) + dz_harm(I,k) - hvel_shelf(I,k) = hvel(I,k) + hvel_shelf(I,k) = hvel(I,k) ; dz_vel_shelf(I,k) = dz_vel(I,k) if (u(I,j,k) * h_delta(I,k) > 0) then if (zh(I) * I_HTbl(I) < CS%harm_BL_val) then hvel_shelf(I,k) = min(hvel(I,k), h_harm(I,k)) + dz_vel_shelf(I,k) = min(dz_vel(I,k), dz_harm(I,k)) else z2_wt = 1.0 ; if (zh(I) * I_HTbl(I) < 2.0*CS%harm_BL_val) & z2_wt = max(0.0, min(1.0, zh(I) * I_HTbl(I) * I_valBL - 1.0)) z2 = z2_wt * (max(zh(I), Ztop_min(I) - min(zcol(i),zcol(i+1))) * I_HTbl(I)) topfn = 1.0 / (1.0 + 0.09*z2**6) hvel_shelf(I,k) = min(hvel(I,k), (1.0-topfn)*h_arith(I,k) + topfn*h_harm(I,k)) + dz_vel_shelf(I,k) = min(dz_vel(I,k), (1.0-topfn)*dz_arith(I,k) + topfn*dz_harm(I,k)) endif endif endif ; enddo enddo endif - call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, forces, & + call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, bbl_thick, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, Ustar_2d, tv, & work_on_u=.true., OBC=OBC, shelf=.true.) do I=Isq,Ieq ; if (do_i_shelf(I)) CS%a1_shelf_u(I,j) = a_shelf(I,1) ; enddo endif @@ -1232,10 +1256,10 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, endif ; enddo ; enddo else do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then - CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) endif; enddo ; enddo do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then - CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) endif; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) + h_neglect ; enddo ; enddo endif @@ -1243,28 +1267,29 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, ! Diagnose total Kv at u-points if (CS%id_Kv_u > 0) then do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) Kv_u(I,j,k) = 0.5 * GV%H_to_Z*(CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) + if (do_i(I)) Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) enddo ; enddo endif ! Diagnose GL90 Kv at u-points if (CS%id_Kv_gl90_u > 0) then do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) Kv_gl90_u(I,j,k) = 0.5 * GV%H_to_Z*(CS%a_u_gl90(I,j,K)+CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) + if (do_i(I)) Kv_gl90_u(I,j,k) = 0.5 * (CS%a_u_gl90(I,j,K)+CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) enddo ; enddo endif enddo ! 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,a_cpl_max) & - !$OMP firstprivate(i_hbbl) + !$OMP parallel do default(private) shared(G,GV,US,CS,tv,OBC,visc,is,ie,Jsq,Jeq,nz,v,h,dz,forces, & + !$OMP Ustar_2d,h_neglect,dz_neglect,dt,I_valBL,hML_v,Kv_v, & + !$OMP a_cpl_max,I_Hbbl_gl90,Kv_gl90_v) & + !$OMP firstprivate(I_Hbbl) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do i=is,ie - kv_bbl(i) = GV%H_to_Z*visc%Kv_bbl_v(i,J) - bbl_thick(i) = visc%bbl_thick_v(i,J) * GV%Z_to_H + h_neglect + kv_bbl(i) = visc%Kv_bbl_v(i,J) + bbl_thick(i) = visc%bbl_thick_v(i,J) + dz_neglect if (do_i(i)) I_Hbbl(i) = 1.0 / bbl_thick(i) enddo ; endif @@ -1272,9 +1297,11 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, h_harm(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / (h(i,j,k)+h(i,j+1,k)+h_neglect) h_arith(i,k) = 0.5*(h(i,j+1,k)+h(i,j,k)) h_delta(i,k) = h(i,j+1,k) - h(i,j,k) + dz_harm(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / (dz(i,j,k)+dz(i,j+1,k)+dz_neglect) + dz_arith(i,k) = 0.5*(dz(i,j+1,k)+dz(i,j,k)) endif ; enddo ; enddo do i=is,ie - Dmin(i) = min(G%bathyT(i,j), G%bathyT(i,j+1)) * GV%Z_to_H + Dmin(i) = min(G%bathyT(i,j), G%bathyT(i,j+1)) zi_dir(i) = 0 enddo @@ -1282,12 +1309,18 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do k=1,nz ; h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(i,k) = 0. ; enddo - Dmin(I) = G%bathyT(i,j) * GV%Z_to_H + do k=1,nz + h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(i,k) = 0. + dz_harm(I,k) = dz(i,j,k) ; dz_arith(I,k) = dz(i,j,k) + enddo + Dmin(I) = G%bathyT(i,j) zi_dir(I) = -1 elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do k=1,nz ; h_harm(i,k) = h(i,j+1,k) ; h_arith(i,k) = h(i,j+1,k) ; h_delta(i,k) = 0. ; enddo - Dmin(i) = G%bathyT(i,j+1) * GV%Z_to_H + do k=1,nz + h_harm(i,k) = h(i,j+1,k) ; h_arith(i,k) = h(i,j+1,k) ; h_delta(i,k) = 0. + dz_harm(i,k) = dz(i,j+1,k) ; dz_arith(i,k) = dz(i,j+1,k) + enddo + Dmin(i) = G%bathyT(i,j+1) zi_dir(i) = 1 endif endif ; enddo @@ -1303,21 +1336,23 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then hvel(i,k) = h_harm(i,k) + dz_vel(i,k) = dz_harm(i,k) if (v(i,J,k) * h_delta(i,k) < 0) then z2 = z_i(i,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) hvel(i,k) = (1.0-botfn)*h_harm(i,k) + botfn*h_arith(i,k) + dz_vel(i,k) = (1.0-botfn)*dz_harm(i,k) + botfn*dz_arith(i,k) endif - z_i(i,k) = z_i(i,k+1) + h_harm(i,k)*I_Hbbl(i) + z_i(i,k) = z_i(i,k+1) + dz_harm(i,k)*I_Hbbl(i) endif ; enddo ; enddo ! i & k loops else ! Not harmonic_visc do i=is,ie zh(i) = 0.0 ; z_i(i,nz+1) = 0.0 - zcol1(i) = -G%bathyT(i,j) * GV%Z_to_H - zcol2(i) = -G%bathyT(i,j+1) * GV%Z_to_H + zcol1(i) = -G%bathyT(i,j) + zcol2(i) = -G%bathyT(i,j+1) enddo do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then - zh(i) = zh(i) + h_harm(i,k) - zcol1(i) = zcol1(i) + h(i,j,k) ; zcol2(i) = zcol2(i) + h(i,j+1,k) + zh(i) = zh(i) + dz_harm(i,k) + zcol1(i) = zcol1(i) + dz(i,j,k) ; zcol2(i) = zcol2(i) + dz(i,j+1,k) z_clear = max(zcol1(i),zcol2(i)) + Dmin(i) if (zi_dir(i) < 0) z_clear = zcol1(i) + Dmin(I) @@ -1326,23 +1361,26 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, z_i(I,k) = max(zh(i), z_clear) * I_Hbbl(i) hvel(i,k) = h_arith(i,k) + dz_vel(i,k) = dz_arith(i,k) if (v(i,J,k) * h_delta(i,k) > 0) then if (zh(i) * I_Hbbl(i) < CS%harm_BL_val) then hvel(i,k) = h_harm(i,k) + dz_vel(i,k) = dz_harm(i,k) else z2_wt = 1.0 ; if (zh(i) * I_Hbbl(i) < 2.0*CS%harm_BL_val) & z2_wt = max(0.0, min(1.0, zh(i) * I_Hbbl(i) * I_valBL - 1.0)) z2 = z2_wt * (max(zh(i), max(zcol1(i),zcol2(i)) + Dmin(i)) * I_Hbbl(i)) botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) hvel(i,k) = (1.0-botfn)*h_arith(i,k) + botfn*h_harm(i,k) + dz_vel(i,k) = (1.0-botfn)*dz_arith(i,k) + botfn*dz_harm(i,k) endif endif endif ; enddo ; enddo ! i & k loops endif - call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u=.false., OBC=OBC) + call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.false., OBC=OBC) a_cpl_gl90(:,:) = 0.0 if (CS%use_GL90_in_SSW) then ! The following block calculates the normalized height above the GL90 @@ -1356,10 +1394,10 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do i=is,ie ; z_i_gl90(i,nz+1) = 0.0 ; enddo do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then - z_i_gl90(i,k) = z_i_gl90(i,k+1) + h_harm(i,k)*I_Hbbl_gl90(i) + z_i_gl90(i,k) = z_i_gl90(i,k+1) + dz_harm(i,k)*I_Hbbl_gl90(i) endif ; enddo ; enddo ! i & k loops - call find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.false.) + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.false.) endif if ( allocated(hML_v)) then @@ -1374,35 +1412,39 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, enddo if (do_any_shelf) then if (CS%harmonic_visc) then - do k=1,nz ; do i=is,ie ; hvel_shelf(i,k) = hvel(i,k) ; enddo ; enddo + do k=1,nz ; do i=is,ie + hvel_shelf(i,k) = hvel(i,k) ; dz_vel_shelf(i,k) = dz_vel(i,k) + enddo ; enddo else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. do i=is,ie ; if (do_i_shelf(i)) then zh(i) = 0.0 ; Ztop_min(I) = min(zcol1(i), zcol2(i)) - I_HTbl(i) = 1.0 / (visc%tbl_thick_shelf_v(i,J)*GV%Z_to_H + h_neglect) + I_HTbl(i) = 1.0 / (visc%tbl_thick_shelf_v(i,J) + dz_neglect) endif ; enddo do k=1,nz do i=is,ie ; if (do_i_shelf(i)) then - zcol1(i) = zcol1(i) - h(i,j,k) ; zcol2(i) = zcol2(i) - h(i,j+1,k) - zh(i) = zh(i) + h_harm(i,k) + zcol1(i) = zcol1(i) - dz(i,j,k) ; zcol2(i) = zcol2(i) - dz(i,j+1,k) + zh(i) = zh(i) + dz_harm(i,k) - hvel_shelf(i,k) = hvel(i,k) + hvel_shelf(i,k) = hvel(i,k) ; dz_vel_shelf(i,k) = dz_vel(i,k) if (v(i,J,k) * h_delta(i,k) > 0) then if (zh(i) * I_HTbl(i) < CS%harm_BL_val) then hvel_shelf(i,k) = min(hvel(i,k), h_harm(i,k)) + dz_vel_shelf(i,k) = min(dz_vel(i,k), dz_harm(i,k)) else z2_wt = 1.0 ; if (zh(i) * I_HTbl(i) < 2.0*CS%harm_BL_val) & z2_wt = max(0.0, min(1.0, zh(i) * I_HTbl(i) * I_valBL - 1.0)) z2 = z2_wt * (max(zh(i), Ztop_min(i) - min(zcol1(i),zcol2(i))) * I_HTbl(i)) topfn = 1.0 / (1.0 + 0.09*z2**6) hvel_shelf(i,k) = min(hvel(i,k), (1.0-topfn)*h_arith(i,k) + topfn*h_harm(i,k)) + dz_vel_shelf(i,k) = min(dz_vel(i,k), (1.0-topfn)*dz_arith(i,k) + topfn*dz_harm(i,k)) endif endif endif ; enddo enddo endif - call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, forces, & + call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, bbl_thick, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, Ustar_2d, tv, & work_on_u=.false., OBC=OBC, shelf=.true.) do i=is,ie ; if (do_i_shelf(i)) CS%a1_shelf_v(i,J) = a_shelf(i,1) ; enddo endif @@ -1432,20 +1474,20 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, endif ; enddo ; enddo do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) then CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,K)) - endif ; enddo ; enddo + endif ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) + h_neglect ; enddo ; enddo endif ! Diagnose total Kv at v-points if (CS%id_Kv_v > 0) then do k=1,nz ; do i=is,ie - if (do_i(I)) Kv_v(i,J,k) = 0.5 * GV%H_to_Z*(CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) + if (do_i(I)) Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) enddo ; enddo endif ! Diagnose GL90 Kv at v-points if (CS%id_Kv_gl90_v > 0) then do k=1,nz ; do i=is,ie - if (do_i(I)) Kv_gl90_v(i,J,k) = 0.5 * GV%H_to_Z*(CS%a_v_gl90(i,J,K)+CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) + if (do_i(I)) Kv_gl90_v(i,J,k) = 0.5 * (CS%a_v_gl90(i,J,K)+CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) enddo ; enddo endif enddo ! end of v-point j loop @@ -1454,10 +1496,10 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & scale=GV%H_to_m, scalar_pair=.true.) call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, & - scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(hML_u) .and. allocated(hML_v)) & call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, & - haloshift=0, scale=GV%H_to_m, scalar_pair=.true.) + haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) endif ! Offer diagnostic fields for averaging. @@ -1487,32 +1529,38 @@ end subroutine vertvisc_coef !! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent !! layer thicknesses are used to calculate a_cpl near the bottom. subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u, OBC, shelf) + dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZK_(GV)+1), & - intent(out) :: a_cpl !< Coupling coefficient across interfaces [Z T-1 ~> m s-1]. + intent(out) :: a_cpl !< Coupling coefficient across interfaces [H T-1 ~> m s-1 or Pa s m-1] real, dimension(SZIB_(G),SZK_(GV)), & - intent(in) :: hvel !< Thickness at velocity points [H ~> m or kg m-2] + intent(in) :: hvel !< Distance between interfaces at velocity points [Z ~> m] logical, dimension(SZIB_(G)), & intent(in) :: do_i !< If true, determine coupling coefficient for a column real, dimension(SZIB_(G),SZK_(GV)), & intent(in) :: h_harm !< Harmonic mean of thicknesses around a velocity - !! grid point [H ~> m or kg m-2] - real, dimension(SZIB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [H ~> m or kg m-2] + !! grid point [Z ~> m] + real, dimension(SZIB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m] real, dimension(SZIB_(G)), intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of !! any depth-dependent contributions from - !! visc%Kv_shear [Z2 T-1 ~> m2 s-1]. + !! visc%Kv_shear [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZIB_(G),SZK_(GV)+1), & intent(in) :: z_i !< Estimate of interface heights above the bottom, !! normalized by the bottom boundary layer thickness [nondim] - real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [H ~> m or kg m-2] + real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [Z ~> m] integer, intent(in) :: j !< j-index to find coupling coefficient for real, intent(in) :: dt !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure type(vertvisc_type), intent(in) :: visc !< Structure containing viscosities and bottom drag - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: Ustar_2d !< The wind friction velocity, calculated using + !! the Boussinesq reference density or the + !! time-evolving surface density in non-Boussinesq + !! mode [Z T-1 ~> m s-1] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. logical, intent(in) :: work_on_u !< If true, u-points are being calculated, !! otherwise they are v-points type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure @@ -1522,38 +1570,38 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! Local variables real, dimension(SZIB_(G)) :: & - u_star, & ! ustar at a velocity point [Z T-1 ~> m s-1]. - tau_mag, & ! The magnitude of the wind stress at a velocity point including gustiness, - ! divided by the Boussinesq refernce density [Z2 T-2 ~> m2 s-2] + u_star, & ! ustar at a velocity point [Z T-1 ~> m s-1] + tau_mag, & ! The magnitude of the wind stress at a velocity point including gustiness [H Z T-2 ~> m2 s-2 or Pa] absf, & ! The average of the neighboring absolute values of f [T-1 ~> s-1]. -! h_ml, & ! The mixed layer depth [H ~> m or kg m-2]. + rho_av1, & ! The harmonic mean surface layer density at velocity points [R ~> kg m-3] z_t, & ! The distance from the top, sometimes normalized - ! by Hmix, [H ~> m or kg m-2] or [nondim]. - kv_TBL, & ! The viscosity in a top boundary layer under ice [Z2 T-1 ~> m2 s-1]. - tbl_thick ! The thickness of the top boundary layer [H ~> m or kg m-2] + ! by Hmix, [Z ~> m] or [nondim]. + kv_TBL, & ! The viscosity in a top boundary layer under ice [H Z T-1 ~> m2 s-1 or Pa s] + tbl_thick ! The thickness of the top boundary layer [Z ~> m] real, dimension(SZIB_(G),SZK_(GV)+1) :: & - Kv_tot, & ! The total viscosity at an interface [Z2 T-1 ~> m2 s-1]. - Kv_add ! A viscosity to add [Z2 T-1 ~> m2 s-1]. + Kv_tot, & ! The total viscosity at an interface [H Z T-1 ~> m2 s-1 or Pa s] + Kv_add ! A viscosity to add [H Z T-1 ~> m2 s-1 or Pa s] integer, dimension(SZIB_(G)) :: & nk_in_ml ! The index of the deepest interface in the mixed layer. - real :: h_shear ! The distance over which shears occur [H ~> m or kg m-2]. - real :: dhc ! The distance between the center of adjacent layers [H ~> m or kg m-2]. - real :: visc_ml ! The mixed layer viscosity [Z2 T-1 ~> m2 s-1]. - real :: I_Hmix ! The inverse of the mixed layer thickness [H-1 ~> m-1 or m2 kg-1]. + real :: h_shear ! The distance over which shears occur [Z ~> m]. + real :: dhc ! The distance between the center of adjacent layers [Z ~> m]. + real :: visc_ml ! The mixed layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + real :: tau_scale ! A scaling factor for the interpolated wind stress magnitude [H R-1 L-1 ~> m3 kg-1 or nondim] + real :: I_Hmix ! The inverse of the mixed layer thickness [Z-1 ~> m-1]. real :: a_ml ! The layer coupling coefficient across an interface in - ! the mixed layer [Z T-1 ~> m s-1]. + ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1]. real :: a_floor ! A lower bound on the layer coupling coefficient across an interface in - ! the mixed layer [Z T-1 ~> m s-1]. - real :: I_amax ! The inverse of the maximum coupling coefficient [T Z-1 ~> s m-1]. - real :: temp1 ! A temporary variable [H Z ~> m2 or kg m-1] + ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1]. + real :: I_amax ! The inverse of the maximum coupling coefficient [T H-1 ~> s m-1 or s m2 kg-1]. + real :: temp1 ! A temporary variable [Z2 ~> m2] real :: ustar2_denom ! A temporary variable in the surface boundary layer turbulence - ! calculations [Z H-1 T-1 ~> s-1 or m3 kg-1 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]. + ! calculations [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + real :: h_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: z2 ! A copy of z_i [nondim] real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: topfn ! A function that is 1 at the top and small far from it [nondim] - real :: kv_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] + real :: kv_top ! A viscosity associated with the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] logical :: do_shelf, do_OBCs, can_exit integer :: i, k, is, ie, max_nk integer :: nz @@ -1564,13 +1612,15 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, if (work_on_u) then ; is = G%IscB ; ie = G%IecB else ; is = G%isc ; ie = G%iec ; endif nz = GV%ke - h_neglect = GV%H_subroundoff + h_neglect = GV%dZ_subroundoff + + tau_scale = US%L_to_Z * GV%RZ_to_H if (CS%answer_date < 20190101) then ! The maximum coupling coefficient was originally introduced to avoid ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 ! sets the maximum coupling coefficient increment to 1e10 m per timestep. - I_amax = (1.0e-10*US%Z_to_m) * dt + I_amax = (1.0e-10*GV%H_to_m) * dt else I_amax = 0.0 endif @@ -1609,14 +1659,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! layer thicknesses or the surface wind stresses are added later. if (work_on_u) then do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = GV%H_to_Z*0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) + Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) endif ; enddo ; enddo if (do_OBCs) then do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i+1,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i+1,j,k) ; enddo endif endif ; enddo endif @@ -1625,14 +1675,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif ; enddo ; enddo else do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = GV%H_to_Z*0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) + Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) endif ; enddo ; enddo if (do_OBCs) then do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j+1,k) ; enddo + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j+1,k) ; enddo endif endif ; enddo endif @@ -1648,11 +1698,11 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! to further modify these viscosities here to take OBCs into account. if (work_on_u) then do K=2,nz ; do I=Is,Ie ; If (do_i(I)) then - Kv_tot(I,K) = Kv_tot(I,K) + GV%H_to_Z*(0.5)*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) + Kv_tot(I,K) = Kv_tot(I,K) + 0.5*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) endif ; enddo ; enddo else do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + GV%H_to_Z*(0.5)*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) + Kv_tot(i,K) = Kv_tot(i,K) + 0.5*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) endif ; enddo ; enddo endif endif @@ -1665,9 +1715,9 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! These expressions assume that Kv_tot(i,nz+1) = CS%Kv, consistent with ! the suppression of turbulent mixing by the presence of a solid boundary. if (dhc < bbl_thick(i)) then - a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + (dhc+h_neglect)*GV%H_to_Z) + a_cpl(i,nz+1) = kv_bbl(i) / ((dhc+h_neglect) + I_amax*kv_bbl(i)) else - a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + (bbl_thick(i)+h_neglect)*GV%H_to_Z) + a_cpl(i,nz+1) = kv_bbl(i) / ((bbl_thick(i)+h_neglect) + I_amax*kv_bbl(i)) endif endif ; enddo do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then @@ -1685,14 +1735,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear*GV%H_to_Z + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) endif ; enddo ; enddo ! i & k loops elseif (abs(CS%Kv_extra_bbl) > 0.0) then ! There is a simple enhancement of the near-bottom viscosities, but no adjustment ! of the viscous coupling length scales to give a particular bottom stress. do i=is,ie ; if (do_i(i)) then a_cpl(i,nz+1) = (Kv_tot(i,nz+1) + CS%Kv_extra_bbl) / & - ((0.5*hvel(i,nz)+h_neglect)*GV%H_to_Z + I_amax*(Kv_tot(i,nz+1)+CS%Kv_extra_bbl)) + ((0.5*hvel(i,nz)+h_neglect) + I_amax*(Kv_tot(i,nz+1)+CS%Kv_extra_bbl)) endif ; enddo do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then ! botfn determines when a point is within the influence of the bottom @@ -1704,18 +1754,18 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_shear = 0.5*(hvel(i,k) + hvel(i,k-1) + h_neglect) ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear*GV%H_to_Z + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) endif ; enddo ; enddo ! i & k loops else ! Any near-bottom viscous enhancements were already incorporated into Kv_tot, and there is ! no adjustment of the viscous coupling length scales to give a particular bottom stress. do i=is,ie ; if (do_i(i)) then - a_cpl(i,nz+1) = Kv_tot(i,nz+1) / ((0.5*hvel(i,nz)+h_neglect)*GV%H_to_Z + I_amax*Kv_tot(i,nz+1)) + a_cpl(i,nz+1) = Kv_tot(i,nz+1) / ((0.5*hvel(i,nz)+h_neglect) + I_amax*Kv_tot(i,nz+1)) endif ; enddo do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then h_shear = 0.5*(hvel(i,k) + hvel(i,k-1) + h_neglect) ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear*GV%H_to_Z + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) endif ; enddo ; enddo ! i & k loops endif @@ -1726,19 +1776,19 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! Set the coefficients to include the no-slip surface stress. do i=is,ie ; if (do_i(i)) then if (work_on_u) then - kv_TBL(i) = GV%H_to_Z*visc%Kv_tbl_shelf_u(I,j) - tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) * GV%Z_to_H + h_neglect + kv_TBL(i) = visc%Kv_tbl_shelf_u(I,j) + tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) + h_neglect else - kv_TBL(i) = GV%H_to_Z*visc%Kv_tbl_shelf_v(i,J) - tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) * GV%Z_to_H + h_neglect + kv_TBL(i) = visc%Kv_tbl_shelf_v(i,J) + tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) + h_neglect endif z_t(i) = 0.0 ! If a_cpl(i,1) were not already 0, it would be added here. if (0.5*hvel(i,1) > tbl_thick(i)) then - a_cpl(i,1) = kv_TBL(i) / (tbl_thick(i)*GV%H_to_Z + I_amax*kv_TBL(i)) + a_cpl(i,1) = kv_TBL(i) / (tbl_thick(i) + I_amax*kv_TBL(i)) else - a_cpl(i,1) = kv_TBL(i) / ((0.5*hvel(i,1)+h_neglect)*GV%H_to_Z + I_amax*kv_TBL(i)) + a_cpl(i,1) = kv_TBL(i) / ((0.5*hvel(i,1)+h_neglect) + I_amax*kv_TBL(i)) endif endif ; enddo @@ -1754,35 +1804,78 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif kv_top = topfn * kv_TBL(i) - a_cpl(i,K) = a_cpl(i,K) + kv_top / (h_shear*GV%H_to_Z + I_amax*kv_top) + a_cpl(i,K) = a_cpl(i,K) + kv_top / (h_shear + I_amax*kv_top) endif ; enddo ; enddo elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then ! Find the friction velocity and the absolute value of the Coriolis parameter at this point. u_star(:) = 0.0 ! Zero out the friction velocity on land points. - if (work_on_u) then - do I=is,ie ; if (do_i(I)) then - u_star(I) = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) - absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - endif ; enddo - if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) & - u_star(I) = forces%ustar(i,j) - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) & - u_star(I) = forces%ustar(i+1,j) - endif ; enddo ; endif - else - do i=is,ie ; if (do_i(i)) then - u_star(i) = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) - absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - endif ; enddo - if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) & - u_star(i) = forces%ustar(i,j) - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) & - u_star(i) = forces%ustar(i,j+1) - endif ; enddo ; endif + tau_mag(:) = 0.0 ! Zero out the friction velocity on land points. + + if (allocated(tv%SpV_avg)) then + rho_av1(:) = 0.0 + if (work_on_u) then + do I=is,ie ; if (do_i(I)) then + u_star(I) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) + rho_av1(I) = 2.0 / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1)) + absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + u_star(I) = Ustar_2d(i,j) + rho_av1(I) = 1.0 / tv%SpV_avg(i,j,1) + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + u_star(I) = Ustar_2d(i+1,j) + rho_av1(I) = 1.0 / tv%SpV_avg(i+1,j,1) + endif + endif ; enddo ; endif + else ! Work on v-points + do i=is,ie ; if (do_i(i)) then + u_star(i) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) + rho_av1(i) = 2.0 / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1)) + absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + u_star(i) = Ustar_2d(i,j) + rho_av1(i) = 1.0 / tv%SpV_avg(i,j,1) + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + u_star(i) = Ustar_2d(i,j+1) + rho_av1(i) = 1.0 / tv%SpV_avg(i,j+1,1) + endif + endif ; enddo ; endif + endif + do I=is,ie + tau_mag(I) = GV%RZ_to_H*rho_av1(i) * u_star(I)**2 + enddo + else ! (.not.allocated(tv%SpV_avg)) + if (work_on_u) then + do I=is,ie ; if (do_i(I)) then + u_star(I) = 0.5*(Ustar_2d(i,j) + Ustar_2d(i+1,j)) + absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) & + u_star(I) = Ustar_2d(i,j) + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) & + u_star(I) = Ustar_2d(i+1,j) + endif ; enddo ; endif + else + do i=is,ie ; if (do_i(i)) then + u_star(i) = 0.5*(Ustar_2d(i,j) + Ustar_2d(i,j+1)) + absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) & + u_star(i) = Ustar_2d(i,j) + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) & + u_star(i) = Ustar_2d(i,j+1) + endif ; enddo ; endif + endif + do I=is,ie + tau_mag(I) = GV%Z_to_H*u_star(I)**2 + enddo endif ! Determine the thickness of the surface ocean boundary layer and its extent in index space. @@ -1863,12 +1956,16 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! The viscosity in visc_ml is set to go to 0 at the mixed layer top and bottom ! (in a log-layer) and be further limited by rotation to give the natural Ekman length. - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z - ustar2_denom = (CS%vonKar * u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H*u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + else + ustar2_denom = (CS%vonKar * tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + endif visc_ml = temp1 * ustar2_denom ! Set the viscous coupling based on the model's vertical resolution. The omission of ! the I_amax factor here is consistent with answer dates above 20190101. - a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) * GV%H_to_Z) + a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect)) ! As a floor on the viscous coupling, assume that the length scale in the denominator can ! not be larger than the distance from the surface, consistent with a logarithmic velocity @@ -1883,8 +1980,12 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then z_t(i) = z_t(i) + hvel(i,k-1) - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z - ustar2_denom = (CS%vonKar * u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H*u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + else + ustar2_denom = (CS%vonKar * tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + endif ! As a floor on the viscous coupling, assume that the length scale in the denominator can not ! be larger than the distance from the surface, consistent with a logarithmic velocity profile. @@ -1894,16 +1995,17 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then z_t(i) = z_t(i) + hvel(i,k-1) - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) ! and be further limited by rotation to give the natural Ekman length. + ! The following expressions are mathematically equivalent. if (GV%Boussinesq .or. (CS%answer_date < 20230601)) then - visc_ml = u_star(i) * CS%vonKar * (temp1*u_star(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + visc_ml = u_star(i) * CS%vonKar * (GV%Z_to_H*temp1*u_star(i)) / & + (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) else - tau_mag(i) = u_star(i)**2 visc_ml = CS%vonKar * (temp1*tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) endif - a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) * GV%H_to_Z + 0.5*I_amax*visc_ml) + a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) + 0.5*I_amax*visc_ml) ! Choose the largest estimate of a_cpl, but these could be changed to be additive. a_cpl(i,K) = max(a_cpl(i,K), a_ml) @@ -2005,7 +2107,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS enddo ! j-loop else ! Do not report accelerations leading to large velocities. if (CS%CFL_based_trunc) then -!$OMP parallel do default(none) shared(nz,js,je,Isq,Ieq,u,dt,G,CS,h,H_report) + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do I=Isq,Ieq if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then @@ -2017,7 +2119,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS endif enddo ; enddo ; enddo else -!$OMP parallel do default(none) shared(nz,js,je,Isq,Ieq,u,G,CS,truncvel,maxvel,h,H_report) + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do I=Isq,Ieq if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 elseif (abs(u(I,j,k)) > maxvel) then @@ -2142,8 +2244,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! Local variables - real :: Kv_BBL ! A viscosity in the bottom boundary layer with a simple scheme [Z2 T-1 ~> m2 s-1]. - real :: Hmix_z ! A boundary layer thickness [Z ~> m]. + real :: Kv_BBL ! A viscosity in the bottom boundary layer with a simple scheme [H Z T-1 ~> m2 s-1 or Pa s] + real :: Kv_back_z ! A background kinematic viscosity [Z2 T-1 ~> m2 s-1] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the @@ -2256,17 +2358,16 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) if (GV%nkml < 1) then - call get_param(param_file, mdl, "HMIX_FIXED", Hmix_z, & + call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & "The prescribed depth over which the near-surface viscosity and "//& "diffusivity are elevated when the bulk mixed layer is not used.", & units="m", scale=US%m_to_Z, fail_if_missing=.true.) - CS%Hmix = GV%Z_to_H * Hmix_z endif if (CS%direct_stress) then if (GV%nkml < 1) then call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & - units="m", default=US%Z_to_m*Hmix_z, scale=GV%m_to_H) + units="m", default=US%Z_to_m*CS%Hmix, scale=GV%m_to_H) else call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & @@ -2275,17 +2376,20 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & if (CS%Hmix_stress <= 0.0) call MOM_error(FATAL, "vertvisc_init: " // & "HMIX_STRESS must be set to a positive value if DIRECT_STRESS is true.") endif - call get_param(param_file, mdl, "KV", CS%Kv, & + call get_param(param_file, mdl, "KV", Kv_back_z, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true., scale=US%m2_s_to_Z2_T) + ! Convert input kinematic viscosity to dynamic viscosity when non-Boussinesq. + CS%Kv = (US%Z2_T_to_m2_s*GV%m2_s_to_HZ_T) * Kv_back_z + call get_param(param_file, mdl, "USE_GL90_IN_SSW", CS%use_GL90_in_SSW, & "If true, use simpler method to calculate 1/N^2 in GL90 vertical "// & "viscosity coefficient. This method is valid in stacked shallow water mode.", & default=.false.) call get_param(param_file, mdl, "KD_GL90", CS%kappa_gl90, & "The scalar diffusivity used in GL90 vertical viscosity scheme.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T, & + units="m2 s-1", default=0.0, scale=US%m_to_L*US%Z_to_L*GV%m_to_H*US%T_to_s, & do_not_log=.not.CS%use_GL90_in_SSW) call get_param(param_file, mdl, "READ_KD_GL90", CS%read_kappa_gl90, & "If true, read a file (given by KD_GL90_FILE) containing the "//& @@ -2309,7 +2413,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & kappa_gl90_file = trim(inputdir) // trim(kappa_gl90_file) allocate(CS%kappa_gl90_2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) - call MOM_read_data(kappa_gl90_file, kdgl90_varname, CS%kappa_gl90_2d(:,:), G%domain, scale=US%m_to_L**2*US%T_to_s) + call MOM_read_data(kappa_gl90_file, kdgl90_varname, CS%kappa_gl90_2d(:,:), G%domain, & + scale=US%m_to_L*US%Z_to_L*GV%m_to_H*US%T_to_s) call pass_var(CS%kappa_gl90_2d, G%domain) endif call get_param(param_file, mdl, "USE_GL90_N2", CS%use_GL90_N2, & @@ -2332,7 +2437,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "viscosity via Kv_GL90 = alpha_GL90 * f2. Is only used "// & "if USE_GL90_N2 is true. Note that the implied Kv_GL90 "// & "corresponds to a KD_GL90 that scales as N^2 with depth.", & - units="m2 s", default=0.0, scale=US%m_to_Z**2*US%s_to_T, & + units="m2 s", default=0.0, scale=GV%m_to_H*US%m_to_Z*US%s_to_T, & do_not_log=.not.CS%use_GL90_in_SSW) endif call get_param(param_file, mdl, "HBBL_GL90", CS%Hbbl_gl90, & @@ -2340,7 +2445,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "which defines the range over which the GL90 coupling "//& "coefficient is zeroed out, in order to avoid fluxing "//& "momentum into vanished layers over steep topography.", & - units="m", default=5.0, scale=GV%m_to_H, do_not_log=.not.CS%use_GL90_in_SSW) + units="m", default=5.0, scale=US%m_to_Z, do_not_log=.not.CS%use_GL90_in_SSW) CS%Kvml_invZ2 = 0.0 if (GV%nkml < 1) then @@ -2359,19 +2464,20 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "transmitted through infinitesimally thin surface layers. This is an "//& "older option for numerical convenience without a strong physical basis, "//& "and its use is now discouraged.", & - units="m2 s-1", default=Kv_mks, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=Kv_mks, scale=GV%m2_s_to_HZ_T) endif if (.not.CS%bottomdraglaw) then call get_param(param_file, mdl, "KV_EXTRA_BBL", CS%Kv_extra_bbl, & "An extra kinematic viscosity in the benthic boundary layer. "//& "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (CS%Kv_extra_bbl == 0.0) then call get_param(param_file, mdl, "KVBBL", Kv_BBL, & "An extra kinematic viscosity in the benthic boundary layer. "//& "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & - units="m2 s-1", default=US%Z2_T_to_m2_s*CS%Kv, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_back_z, scale=GV%m2_s_to_HZ_T, & + do_not_log=.true.) if (abs(Kv_BBL - CS%Kv) > 1.0e-15*abs(CS%Kv)) then call MOM_error(WARNING, "KVBBL is a deprecated parameter. Use KV_EXTRA_BBL instead.") CS%Kv_extra_bbl = Kv_BBL - CS%Kv @@ -2380,14 +2486,14 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & call log_param(param_file, mdl, "KV_EXTRA_BBL", CS%Kv_extra_bbl, & "An extra kinematic viscosity in the benthic boundary layer. "//& "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & - units="m2 s-1", default=0.0, unscale=US%Z2_T_to_m2_s) + units="m2 s-1", default=0.0, unscale=GV%HZ_T_to_m2_s) endif call get_param(param_file, mdl, "HBBL", CS%Hbbl, & "The thickness of a bottom boundary layer with a viscosity increased by "//& "KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which "//& "near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//& "defined but LINEAR_DRAG is not.", & - units="m", fail_if_missing=.true., scale=GV%m_to_H) + units="m", fail_if_missing=.true., scale=US%m_to_Z) call get_param(param_file, mdl, "MAXVEL", CS%maxvel, & "The maximum velocity allowed before the velocity components are truncated.", & units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) @@ -2447,28 +2553,28 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Slow varying vertical viscosity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & - 'Total vertical viscosity at u-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Total vertical viscosity at u-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_Kv_v = register_diag_field('ocean_model', 'Kv_v', diag%axesCvL, Time, & - 'Total vertical viscosity at v-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Total vertical viscosity at v-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_Kv_gl90_u = register_diag_field('ocean_model', 'Kv_gl90_u', diag%axesCuL, Time, & - 'GL90 vertical viscosity at u-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'GL90 vertical viscosity at u-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_Kv_gl90_v = register_diag_field('ocean_model', 'Kv_gl90_v', diag%axesCvL, Time, & - 'GL90 vertical viscosity at v-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'GL90 vertical viscosity at v-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_au_vv = register_diag_field('ocean_model', 'au_visc', diag%axesCui, Time, & - 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_av_vv = register_diag_field('ocean_model', 'av_visc', diag%axesCvi, Time, & - 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_au_gl90_vv = register_diag_field('ocean_model', 'au_gl90_visc', diag%axesCui, Time, & - 'Zonal Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Zonal Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_av_gl90_vv = register_diag_field('ocean_model', 'av_gl90_visc', diag%axesCvi, Time, & - 'Meridional Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Meridional Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & 'Thickness at Zonal Velocity Points for Viscosity', & @@ -2482,11 +2588,11 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', & - thickness_units, conversion=GV%H_to_MKS) + thickness_units, conversion=US%Z_to_m) CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & - thickness_units, conversion=GV%H_to_MKS) + thickness_units, conversion=US%Z_to_m) CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, Time, & 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) From c4ff0214f857806e7c1efdb3610ae9d23dbf3b14 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 16:16:39 -0400 Subject: [PATCH 045/146] *+Add forcing%tau_mag_gustless & tau_mag opt args Added the new tau_mag_gustless element to the forcing type, and set this array in set_derived_forcing_fields if it is associated. Also added new tau_mag optional arguments to the public routines allocate_forcing_by_group() and allocate_mech_forcing_by_group(), with similar mandatory arguments added to the private subroutines get_forcing_groups() and get_mech_forcing_groups(). Tests for an associated pointer were added before all calls setting the ustar, tau_mag or ustar_gustless arrays, preparing for these ustar pointers only to be set when the model is run in Boussinesq mode when the ustar actually make sense. Also use specific volume derivatives to calculate non-Boussinesq mode buoyancy fluxes in calculateBuoyancy_Flux1d, leaving the Boussinesq buoyancy flux calculations unchanged. All answers are bitwise identical in Boussinesq mode, but there is a new element in a transparent type and new optional arguments publicly visible subroutines, and answers will change in non-Boussinesq cases that depend on the surface buoyancyFlux that is returned by calculateBuoyancy_Flux1d. --- src/core/MOM_forcing_type.F90 | 226 +++++++++++++++++++++++----------- 1 file changed, 154 insertions(+), 72 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a6d35903ee..c86b9b869f 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -11,7 +11,7 @@ module MOM_forcing_type use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_alloc, query_averaging_enabled use MOM_diag_mediator, only : enable_averages, disable_averaging -use MOM_EOS, only : calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density_derivs, calculate_specific_vol_derivs, EOS_domain use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -78,8 +78,11 @@ module MOM_forcing_type tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, !! including any contributions from sub-gridscale variability !! or gustiness [R L Z T-2 ~> Pa] - ustar_gustless => NULL() !< surface friction velocity scale without any + ustar_gustless => NULL(), & !< surface friction velocity scale without any !! any augmentation for gustiness [Z T-1 ~> m s-1]. + tau_mag_gustless => NULL() !< Magnitude of the wind stress averaged over tracer cells, + !! without any augmentation for sub-gridscale variability + !! or gustiness [R L Z T-2 ~> Pa] ! surface buoyancy force, used when temperature is not a state variable real, pointer, dimension(:,:) :: & @@ -989,13 +992,19 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt real, dimension(SZI_(G)) :: pressure ! pressure at the surface [R L2 T-2 ~> Pa] real, dimension(SZI_(G)) :: dRhodT ! density partial derivative wrt temp [R C-1 ~> kg m-3 degC-1] real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R S-1 ~> kg m-3 ppt-1] + real, dimension(SZI_(G)) :: dSpV_dT ! Partial derivative of specific volume with respect + ! to temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)) :: dSpV_dS ! Partial derivative of specific volume with respect + ! to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real, dimension(SZI_(G),SZK_(GV)+1) :: netPen ! The net penetrating shortwave radiation at each level ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] logical :: useRiverHeatContent logical :: useCalvingHeatContent - real :: GoRho ! The gravitational acceleration divided by mean density times a - ! unit conversion factor [L2 H-1 R-1 T-2 ~> m4 kg-1 s-2 or m7 kg-2 s-2] + real :: GoRho ! The gravitational acceleration divided by mean density times a + ! unit conversion factor [L2 H-1 R-1 T-2 ~> m4 kg-1 s-2 or m7 kg-2 s-2] + real :: g_conv ! The gravitational acceleration times the conversion factors from non-Boussinesq + ! thickness units to mass per units area [R L2 H-1 T-2 ~> kg m-2 s-2 or m s-2] real :: H_limit_fluxes ! A depth scale that specifies when the ocean is shallow that ! it is necessary to eliminate fluxes [H ~> m or kg m-2] integer :: i, k @@ -1005,9 +1014,6 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt useCalvingHeatContent = .False. H_limit_fluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) - pressure(:) = 0. - if (associated(tv%p_surf)) then ; do i=G%isc,G%iec ; pressure(i) = tv%p_surf(i,j) ; enddo ; endif - GoRho = (GV%g_Earth * GV%H_to_Z) / GV%Rho0 ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: @@ -1027,10 +1033,6 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt call sumSWoverBands(G, GV, US, h(:,j,:), dz, optics_nbands(optics), optics, j, 1.0, & H_limit_fluxes, .true., penSWbnd, netPen) - ! Density derivatives - call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & - tv%eqn_of_state, EOS_domain(G%HI)) - ! Adjust netSalt to reflect dilution effect of FW flux ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) @@ -1041,13 +1043,41 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt !netHeat(:) = netHeatMinusSW(:) + sum( penSWbnd, dim=1 ) netHeat(G%isc:G%iec) = netHeatMinusSW(G%isc:G%iec) + netPen(G%isc:G%iec,1) - ! Convert to a buoyancy flux, excluding penetrating SW heating - buoyancyFlux(G%isc:G%iec,1) = - GoRho * ( dRhodS(G%isc:G%iec) * netSalt(G%isc:G%iec) + & - dRhodT(G%isc:G%iec) * netHeat(G%isc:G%iec) ) ! [L2 T-3 ~> m2 s-3] - ! We also have a penetrative buoyancy flux associated with penetrative SW - do k=2, GV%ke+1 - buoyancyFlux(G%isc:G%iec,k) = - GoRho * ( dRhodT(G%isc:G%iec) * netPen(G%isc:G%iec,k) ) ! [L2 T-3 ~> m2 s-3] - enddo + ! Determine the buoyancy flux + pressure(:) = 0. + if (associated(tv%p_surf)) then ; do i=G%isc,G%iec ; pressure(i) = tv%p_surf(i,j) ; enddo ; endif + + if ((.not.GV%Boussinesq) .and. (.not.GV%semi_Boussinesq)) then + g_conv = GV%g_Earth * GV%H_to_RZ + + ! Specific volume derivatives + call calculate_specific_vol_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, EOS_domain(G%HI)) + + ! Convert to a buoyancy flux [L2 T-3 ~> m2 s-3], first excluding penetrating SW heating + do i=G%isc,G%iec + buoyancyFlux(i,1) = g_conv * (dSpV_dS(i) * netSalt(i) + dSpV_dT(i) * netHeat(i)) + enddo + ! We also have a penetrative buoyancy flux associated with penetrative SW + do k=2,GV%ke+1 ; do i=G%isc,G%iec + buoyancyFlux(i,k) = g_conv * ( dSpV_dT(i) * netPen(i,k) ) ! [L2 T-3 ~> m2 s-3] + enddo ; enddo + else + GoRho = (GV%g_Earth * GV%H_to_Z) / GV%Rho0 + + ! Density derivatives + call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOS_domain(G%HI)) + + ! Convert to a buoyancy flux [L2 T-3 ~> m2 s-3], excluding penetrating SW heating + do i=G%isc,G%iec + buoyancyFlux(i,1) = - GoRho * ( dRhodS(i) * netSalt(i) + dRhodT(i) * netHeat(i) ) + enddo + ! We also have a penetrative buoyancy flux associated with penetrative SW + do k=2,GV%ke+1 ; do i=G%isc,G%iec + buoyancyFlux(i,k) = - GoRho * ( dRhodT(i) * netPen(i,k) ) ! [L2 T-3 ~> m2 s-3] + enddo ; enddo + endif end subroutine calculateBuoyancyFlux1d @@ -2201,34 +2231,55 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) wt2 = 1.0 - wt1 ! = flux_tmp%dt_buoy_accum / (fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum) fluxes%dt_buoy_accum = fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum - ! Copy over the pressure fields and accumulate averages of ustar, either from the forcing + ! Copy over the pressure fields and accumulate averages of ustar or tau_mag, either from the forcing ! type or from the temporary fluxes type. if (present(forces)) then do j=js,je ; do i=is,ie fluxes%p_surf(i,j) = forces%p_surf(i,j) fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) + enddo ; enddo + if (associated(fluxes%ustar)) then ; do j=js,je ; do i=is,ie fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*forces%ustar(i,j) + enddo ; enddo ; endif + if (associated(fluxes%tau_mag)) then ; do j=js,je ; do i=is,ie fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*forces%tau_mag(i,j) - enddo ; enddo + enddo ; enddo ; endif else do j=js,je ; do i=is,ie fluxes%p_surf(i,j) = flux_tmp%p_surf(i,j) fluxes%p_surf_full(i,j) = flux_tmp%p_surf_full(i,j) + enddo ; enddo + if (associated(fluxes%ustar)) then ; do j=js,je ; do i=is,ie fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*flux_tmp%ustar(i,j) + enddo ; enddo ; endif + if (associated(fluxes%tau_mag)) then ; do j=js,je ; do i=is,ie fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*flux_tmp%tau_mag(i,j) - enddo ; enddo + enddo ; enddo ; endif endif - ! Average the water, heat, and salt fluxes, and ustar. - do j=js,je ; do i=is,ie + ! Average ustar_gustless. + if (associated(fluxes%ustar_gustless)) then if (fluxes%gustless_accum_bug) then - fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) + do j=js,je ; do i=is,ie + fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) + enddo ; enddo else - fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + do j=js,je ; do i=is,ie + fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + enddo ; enddo endif + endif + if (associated(fluxes%tau_mag_gustless)) then + do j=js,je ; do i=is,ie + fluxes%tau_mag_gustless(i,j) = wt1*fluxes%tau_mag_gustless(i,j) + wt2*flux_tmp%tau_mag_gustless(i,j) + enddo ; enddo + endif + + ! Average the water, heat, and salt fluxes. + do j=js,je ; do i=is,ie fluxes%evap(i,j) = wt1*fluxes%evap(i,j) + wt2*flux_tmp%evap(i,j) fluxes%lprec(i,j) = wt1*fluxes%lprec(i,j) + wt2*flux_tmp%lprec(i,j) fluxes%fprec(i,j) = wt1*fluxes%fprec(i,j) + wt2*flux_tmp%fprec(i,j) @@ -2383,8 +2434,8 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) Irho0 = US%L_to_Z / Rho0 - if (associated(forces%taux) .and. associated(forces%tauy) .and. & - associated(fluxes%ustar_gustless)) then + if ( associated(forces%taux) .and. associated(forces%tauy) .and. & + (associated(fluxes%ustar_gustless) .or. associated(fluxes%tau_mag_gustless)) ) then do j=js,je ; do i=is,ie taux2 = 0.0 if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & @@ -2397,11 +2448,16 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - if (fluxes%gustless_accum_bug) then - ! This change is just for computational efficiency, but it is wrapped with another change. - fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) - else - fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) + if (associated(fluxes%ustar_gustless)) then + if (fluxes%gustless_accum_bug) then + ! This change is just for computational efficiency, but it is wrapped with another change. + fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) + else + fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) + endif + endif + if (associated(fluxes%tau_mag_gustless)) then + fluxes%tau_mag_gustless(i,j) = sqrt(taux2 + tauy2) endif enddo ; enddo endif @@ -3157,7 +3213,7 @@ end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & shelf, iceberg, salt, fix_accum_bug, cfc, waves, & - shelf_sfc_accumulation, lamult, hevap) + shelf_sfc_accumulation, lamult, hevap, tau_mag) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes @@ -3178,6 +3234,7 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & logical, optional, intent(in) :: hevap !< If present and true, allocate heat content evap. !! This field must be allocated when enthalpy is provided !! via coupler. + logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag and related fields ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -3197,6 +3254,10 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%ustar_gustless,isd,ied,jsd,jed, ustar) call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, ustar) + ! Note that myAlloc can be called safely multiple times for the same pointer. + call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, tau_mag) + call myAlloc(fluxes%tau_mag_gustless,isd,ied,jsd,jed, tau_mag) + call myAlloc(fluxes%evap,isd,ied,jsd,jed, water) call myAlloc(fluxes%lprec,isd,ied,jsd,jed, water) call myAlloc(fluxes%fprec,isd,ied,jsd,jed, water) @@ -3257,20 +3318,20 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & if (present(fix_accum_bug)) fluxes%gustless_accum_bug = .not.fix_accum_bug end subroutine allocate_forcing_by_group - +!> Allocate elements of a new forcing type based on their status in an existing type. subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) - type(forcing), intent(in) :: fluxes_ref !< Reference fluxes - type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes - type(forcing), intent(out) :: fluxes !< Target fluxes + type(forcing), intent(in) :: fluxes_ref !< Reference fluxes + type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes + type(forcing), intent(out) :: fluxes !< Target fluxes - logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & - do_iceberg, do_heat_added, do_buoy + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf + logical :: do_iceberg, do_heat_added, do_buoy - call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_press, & + call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) call allocate_forcing_type(G, fluxes, do_water, do_heat, do_ustar, & - do_press, do_shelf, do_iceberg, do_salt) + do_press, do_shelf, do_iceberg, do_salt, do_taumag) ! The following fluxes would typically be allocated by the driver call myAlloc(fluxes%sw_vis_dir, G%isd, G%ied, G%jsd, G%jed, & @@ -3309,7 +3370,7 @@ end subroutine allocate_forcing_by_ref !> Conditionally allocate fields within the mechanical forcing type using !! control flags. subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & - press, iceberg, waves, num_stk_bands) + press, iceberg, waves, num_stk_bands, tau_mag) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(mech_forcing), intent(inout) :: forces !< Forcing fields structure @@ -3320,6 +3381,7 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & logical, optional, intent(in) :: iceberg !< If present and true, allocate forces for icebergs logical, optional, intent(in) :: waves !< If present and true, allocate wave fields integer, optional, intent(in) :: num_stk_bands !< Number of Stokes bands to allocate + logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -3332,6 +3394,8 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%ustar,isd,ied,jsd,jed, ustar) call myAlloc(forces%tau_mag,isd,ied,jsd,jed, ustar) + ! Note that myAlloc can be called safely multiple times for the same pointer. + call myAlloc(forces%tau_mag,isd,ied,jsd,jed, tau_mag) call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) @@ -3371,24 +3435,25 @@ subroutine allocate_mech_forcing_from_ref(forces_ref, G, forces) type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing type(mech_forcing), intent(out) :: forces !< Mechanical forcing fields - logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg + logical :: do_stress, do_ustar, do_tau_mag, do_shelf, do_press, do_iceberg ! Identify the active fields in the reference forcing - call get_mech_forcing_groups(forces_ref, do_stress, do_ustar, do_shelf, & - do_press, do_iceberg) + call get_mech_forcing_groups(forces_ref, do_stress, do_ustar, do_tau_mag, do_shelf, & + do_press, do_iceberg) call allocate_mech_forcing(G, forces, do_stress, do_ustar, do_shelf, & - do_press, do_iceberg) + do_press, do_iceberg, tau_mag=do_tau_mag) end subroutine allocate_mech_forcing_from_ref !> Return flags indicating which groups of forcings are allocated -subroutine get_forcing_groups(fluxes, water, heat, ustar, press, shelf, & +subroutine get_forcing_groups(fluxes, water, heat, ustar, tau_mag, press, shelf, & iceberg, salt, heat_added, buoy) type(forcing), intent(in) :: fluxes !< Reference flux fields logical, intent(out) :: water !< True if fluxes contains water-based fluxes logical, intent(out) :: heat !< True if fluxes contains heat-based fluxes - logical, intent(out) :: ustar !< True if fluxes contains ustar fluxes + logical, intent(out) :: ustar !< True if fluxes contains ustar + logical, intent(out) :: tau_mag !< True if fluxes contains tau_mag logical, intent(out) :: press !< True if fluxes contains surface pressure logical, intent(out) :: shelf !< True if fluxes contains ice shelf fields logical, intent(out) :: iceberg !< True if fluxes contains iceberg fluxes @@ -3401,6 +3466,7 @@ subroutine get_forcing_groups(fluxes, water, heat, ustar, press, shelf, & ! we handle them here as independent flags. ustar = associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) + tau_mag = associated(fluxes%tau_mag) .and. associated(fluxes%tau_mag_gustless) ! TODO: Check for all associated fields, but for now just check one as a marker water = associated(fluxes%evap) heat = associated(fluxes%seaice_melt_heat) @@ -3414,10 +3480,11 @@ end subroutine get_forcing_groups !> Return flags indicating which groups of mechanical forcings are allocated -subroutine get_mech_forcing_groups(forces, stress, ustar, shelf, press, iceberg) +subroutine get_mech_forcing_groups(forces, stress, ustar, tau_mag, shelf, press, iceberg) type(mech_forcing), intent(in) :: forces !< Reference forcing fields logical, intent(out) :: stress !< True if forces contains wind stress fields logical, intent(out) :: ustar !< True if forces contains ustar field + logical, intent(out) :: tau_mag !< True if forces contains tau_mag field logical, intent(out) :: shelf !< True if forces contains ice shelf fields logical, intent(out) :: press !< True if forces contains pressure fields logical, intent(out) :: iceberg !< True if forces contains iceberg fields @@ -3425,6 +3492,7 @@ subroutine get_mech_forcing_groups(forces, stress, ustar, shelf, press, iceberg) stress = associated(forces%taux) & .and. associated(forces%tauy) ustar = associated(forces%ustar) + tau_mag = associated(forces%tau_mag) shelf = associated(forces%rigidity_ice_u) & .and. associated(forces%rigidity_ice_v) & .and. associated(forces%frac_shelf_u) & @@ -3539,17 +3607,21 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) type(forcing), intent(inout) :: fluxes !< Rotated forcing structure integer, intent(in) :: turns !< Number of quarter turns - logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf, & do_iceberg, do_heat_added, do_buoy - call get_forcing_groups(fluxes_in, do_water, do_heat, do_ustar, do_press, & + call get_forcing_groups(fluxes_in, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) - if (do_ustar) then + if (associated(fluxes_in%ustar)) & call rotate_array(fluxes_in%ustar, turns, fluxes%ustar) + if (associated(fluxes_in%ustar_gustless)) & call rotate_array(fluxes_in%ustar_gustless, turns, fluxes%ustar_gustless) + + if (associated(fluxes_in%tau_mag)) & call rotate_array(fluxes_in%tau_mag, turns, fluxes%tau_mag) - endif + if (associated(fluxes_in%tau_mag_gustless)) & + call rotate_array(fluxes_in%tau_mag_gustless, turns, fluxes%tau_mag_gustless) if (do_water) then call rotate_array(fluxes_in%evap, turns, fluxes%evap) @@ -3670,19 +3742,19 @@ subroutine rotate_mech_forcing(forces_in, turns, forces) integer, intent(in) :: turns !< Number of quarter-turns type(mech_forcing), intent(inout) :: forces !< Forcing on the rotated domain - logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg + logical :: do_stress, do_ustar, do_tau_mag, do_shelf, do_press, do_iceberg - call get_mech_forcing_groups(forces_in, do_stress, do_ustar, do_shelf, & + call get_mech_forcing_groups(forces_in, do_stress, do_ustar, do_tau_mag, do_shelf, & do_press, do_iceberg) if (do_stress) & call rotate_vector(forces_in%taux, forces_in%tauy, turns, & forces%taux, forces%tauy) - if (do_ustar) then + if (associated(forces_in%ustar)) & call rotate_array(forces_in%ustar, turns, forces%ustar) + if (associated(forces_in%tau_mag)) & call rotate_array(forces_in%tau_mag, turns, forces%tau_mag) - endif if (do_shelf) then call rotate_array_pair( & @@ -3726,8 +3798,9 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) !! or updated from mean tau. real :: tx_mean, ty_mean ! Mean wind stresses [R L Z T-2 ~> Pa] + real :: tau_mag ! The magnitude of the wind stresses [R L Z T-2 ~> Pa] real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] - logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg, tau2ustar + logical :: do_stress, do_ustar, do_taumag, do_shelf, do_press, do_iceberg, tau2ustar integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB @@ -3737,7 +3810,7 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) tau2ustar = .false. if (present(UpdateUstar)) tau2ustar = UpdateUstar - call get_mech_forcing_groups(forces, do_stress, do_ustar, do_shelf, & + call get_mech_forcing_groups(forces, do_stress, do_ustar, do_taumag, do_shelf, & do_press, do_iceberg) if (do_stress) then @@ -3750,19 +3823,24 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) if (G%mask2dCv(i,J) > 0.0) forces%tauy(i,J) = ty_mean enddo ; enddo if (tau2ustar) then - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then - forces%tau_mag(i,j) = sqrt(tx_mean**2 + ty_mean**2) - forces%ustar(i,j) = sqrt(forces%tau_mag(i,j) * Irho0) - endif ; enddo ; enddo + tau_mag = sqrt(tx_mean**2 + ty_mean**2) + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + forces%tau_mag(i,j) = tau_mag + endif ; enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + forces%ustar(i,j) = sqrt(tau_mag * Irho0) + endif ; enddo ; enddo ; endif else - call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) - call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) + if (associated(forces%ustar)) & + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & + call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) endif else - if (do_ustar) then + if (associated(forces%ustar)) & call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) - endif endif if (do_shelf) then @@ -3793,17 +3871,21 @@ subroutine homogenize_forcing(fluxes, G, GV, US) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & - do_iceberg, do_heat_added, do_buoy + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf + logical :: do_iceberg, do_heat_added, do_buoy - call get_forcing_groups(fluxes, do_water, do_heat, do_ustar, do_press, & + call get_forcing_groups(fluxes, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) - if (do_ustar) then + if (associated(fluxes%ustar)) & call homogenize_field_t(fluxes%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(fluxes%ustar_gustless)) & call homogenize_field_t(fluxes%ustar_gustless, G, tmp_scale=US%Z_to_m*US%s_to_T) + + if (associated(fluxes%tau_mag)) & call homogenize_field_t(fluxes%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) - endif + if (associated(fluxes%tau_mag_gustless)) & + call homogenize_field_t(fluxes%tau_mag_gustless, G, tmp_scale=US%RLZ_T2_to_Pa) if (do_water) then call homogenize_field_t(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) From 23df7138ee41f180851f6fe6d53eb365f283bd85 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Aug 2023 09:55:19 -0400 Subject: [PATCH 046/146] +*Non-Boussinesq revision of tidal_mixing This commit has a set of changes that set the tidal mixing in non-Boussinesq mode without reference to the Boussinesq reference density, by converting thicknesses to depths via a call to thickness_to_dz, by calculating an average near-bottom density explicitly via a call to find_rho_bottom, and by working with an appropriate mix of layer vertical extents and thicknesses. The contents of find_N2, calculate_tidal_mixing, calculate_CVMix_tidal and add_int_tide_diffusivity are all revised to work directly with vertical distances, set via thickness_to_dz, rather than rescaled thicknesses. This includes replacing the 3-d layer thickness argument to calculate_tidal_mixing, calculate_CVMix_tidal and add_int_tide_diffusivity with a 2-d slice of vertical distances across layers. For find_N2, the 2d-slice of vertical distances is a new argument. The revised code also uses the in situ bottom density when adding certain contributions to non-Boussinesq diffusivities. This change includes the addition of a new bottom density argument to find_N2 and calculate_tidal_mixing, along with a call to find_rho_bottom to set this density. There is also a new runtime parameter, DZ_BBL_AVG_MIN, stored in set_diffusivity_CS, that helps determine the vertical extent of that average. There are a total of 6 new (or renamed) internal variables, and 6 new subroutine arguments, with revisions to the rank of one internal variable. The units of 2 internal variables and 1 element of the tidal_mixing_cs type are altered. This commit eliminates 22 factors of GV%H_to_Z and two direct uses of GV%Rho0. All answers are bitwise identical in Boussinesq mode, but solutions will change in non-Boussinesq mode with this commit. There are several new arguments to a publicly visible subroutine, and a new runtime parameter. --- .../vertical/MOM_set_diffusivity.F90 | 79 +++++--- .../vertical/MOM_tidal_mixing.F90 | 190 +++++++++--------- 2 files changed, 147 insertions(+), 122 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 32553de3d1..2aac478086 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -22,6 +22,7 @@ module MOM_set_diffusivity use MOM_forcing_type, only : forcing, optics_type use MOM_full_convection, only : full_convection use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss use MOM_intrinsic_functions, only : invcosh use MOM_io, only : slasher, MOM_read_data @@ -77,6 +78,8 @@ module MOM_set_diffusivity real :: BBL_effic !< efficiency with which the energy extracted !! by bottom drag drives BBL diffusion [nondim] real :: cdrag !< quadratic drag coefficient [nondim] + real :: dz_BBL_avg_min !< A minimal distance over which to average to determine the average + !! bottom boundary layer density [Z ~> m] real :: IMax_decay !< inverse of a maximum decay scale for !! bottom-drag driven turbulence [Z-1 ~> m-1]. real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] @@ -242,8 +245,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! local variables - real, dimension(SZI_(G)) :: & - N2_bot ! bottom squared buoyancy frequency [T-2 ~> s-2] + real :: N2_bot(SZI_(G)) ! Bottom squared buoyancy frequency [T-2 ~> s-2] + real :: rho_bot(SZI_(G)) ! In situ near-bottom density [T-2 ~> s-2] type(diffusivity_diags) :: dd ! structure with arrays of available diags @@ -254,6 +257,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i real, dimension(SZI_(G),SZK_(GV)) :: & N2_lay, & !< Squared buoyancy frequency associated with layers [T-2 ~> s-2] Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + dz, & !< Height change across layers [Z ~> m] maxTKE, & !< Energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer @@ -396,13 +400,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! be an appropriate place to add a depth-dependent parameterization or another explicit ! parameterization of Kd. - !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,& - !$OMP N2_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb)& + !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,dz, & + !$OMP N2_bot,rho_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & !$OMP if(.not. CS%use_CVMix_ddiff) do j=js,je ! Set up variables related to the stratification. - call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot) + call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot) if (associated(dd%N2_3d)) then do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo @@ -496,13 +500,17 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i enddo ; enddo endif + if (CS%ML_radiation .or. CS%use_tidal_mixing .or. associated(dd%Kd_work)) then + call thickness_to_dz(h, tv, dz, j, G, GV) + endif + ! Add the ML_Rad diffusivity. if (CS%ML_radiation) & call add_MLrad_diffusivity(h, fluxes, j, Kd_int_2d, G, GV, US, CS, TKE_to_Kd, Kd_lay_2d) ! Add the Nikurashin and / or tidal bottom-driven mixing if (CS%use_tidal_mixing) & - call calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, & + call calculate_tidal_mixing(dz, j, N2_bot, rho_bot, N2_lay, N2_int, TKE_to_Kd, & maxTKE, G, GV, US, CS%tidal_mixing, & CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d) @@ -869,7 +877,7 @@ end subroutine find_TKE_to_Kd !> Calculate Brunt-Vaisala frequency, N^2. subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & - N2_lay, N2_int, N2_bot) + N2_lay, N2_int, N2_bot, Rho_bot) 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 @@ -894,24 +902,28 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real, dimension(SZI_(G),SZK_(GV)), & intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [T-2 ~> s-2]. real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & + pres, & ! pressure at each interface [R L2 T-2 ~> Pa] dRho_int_unfilt, & ! unfiltered density differences across interfaces [R ~> kg m-3] dRho_dT, & ! partial derivative of density wrt temp [R C-1 ~> kg m-3 degC-1] dRho_dS ! partial derivative of density wrt saln [R S-1 ~> kg m-3 ppt-1] - + real, dimension(SZI_(G),SZK_(GV)) :: & + dz ! Height change across layers [Z ~> m] real, dimension(SZI_(G)) :: & - pres, & ! pressure at each interface [R L2 T-2 ~> Pa] Temp_int, & ! temperature at each interface [C ~> degC] Salin_int, & ! salinity at each interface [S ~> ppt] drho_bot, & ! A density difference [R ~> kg m-3] h_amp, & ! The topographic roughness amplitude [Z ~> m]. - hb, & ! The thickness of the bottom layer [Z ~> m]. - z_from_bot ! The hieght above the bottom [Z ~> m]. + dz_BBL_avg, & ! The distance over which to average to find the near-bottom density [Z ~> m] + hb, & ! The thickness of the bottom layer [H ~> m or kg m-2] + z_from_bot ! The height above the bottom [Z ~> m] - real :: dz_int ! thickness associated with an interface [Z ~> m]. - real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density - ! times some unit conversion factors [Z T-2 R-1 ~> m4 s-2 kg-1]. + real :: dz_int ! Vertical distance associated with an interface [Z ~> m] + real :: G_Rho0 ! Gravitational acceleration, perhaps divided by Boussinesq reference density, + ! times some unit conversion factors [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. real :: H_neglect ! A negligibly small thickness [H ~> m or kg m-2] logical :: do_i(SZI_(G)), do_any @@ -919,7 +931,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = GV%ke - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 + G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -929,24 +941,24 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i,1) = fluxes%p_surf(i,j) ; enddo else - do i=is,ie ; pres(i) = 0.0 ; enddo + do i=is,ie ; pres(i,1) = 0.0 ; enddo endif EOSdom(:) = EOS_domain(G%HI) do K=2,nz do i=is,ie - pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) + pres(i,K) = pres(i,K-1) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:,K), dRho_dS(:,K), & + call calculate_density_derivs(Temp_int, Salin_int, pres(:,K), dRho_dT(:,K), dRho_dS(:,K), & tv%eqn_of_state, EOSdom) do i=is,ie dRho_int(i,K) = max(dRho_dT(i,K)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i,K)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) dRho_int_unfilt(i,K) = max(dRho_dT(i,K)*(tv%T(i,j,k) - tv%T(i,j,k-1)) + & - dRho_dS(i,K)*(tv%S(i,j,k) - tv%S(i,j,k-1)), 0.0) + dRho_dS(i,K)*(tv%S(i,j,k) - tv%S(i,j,k-1)), 0.0) enddo enddo else @@ -955,21 +967,24 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo ; enddo endif + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + ! Set the buoyancy frequencies. do k=1,nz ; do i=is,ie N2_lay(i,k) = G_Rho0 * 0.5*(dRho_int(i,K) + dRho_int(i,K+1)) / & - (GV%H_to_Z*(h(i,j,k) + H_neglect)) + (h(i,j,k) + H_neglect) enddo ; enddo do i=is,ie ; N2_int(i,1) = 0.0 ; N2_int(i,nz+1) = 0.0 ; enddo do K=2,nz ; do i=is,ie N2_int(i,K) = G_Rho0 * dRho_int(i,K) / & - (0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k) + H_neglect)) + (0.5*(h(i,j,k-1) + h(i,j,k) + H_neglect)) enddo ; enddo ! Find the bottom boundary layer stratification, and use this in the deepest layers. do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 ; h_amp(i) = 0.0 - z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = 0.5*dz(i,nz) do_i(i) = (G%mask2dT(i,j) > 0.0) enddo if (CS%use_tidal_mixing) call tidal_mixing_h_amp(h_amp, G, j, CS%tidal_mixing) @@ -977,16 +992,16 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above - hb(i) = hb(i) + dz_int + hb(i) = hb(i) + 0.5*(h(i,j,k) + h(i,j,k-1)) drho_bot(i) = drho_bot(i) + dRho_int(i,K) if (z_from_bot(i) > h_amp(i)) then if (k>2) then ! Always include at least one full layer. - hb(i) = hb(i) + 0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k-2)) + hb(i) = hb(i) + 0.5*(h(i,j,k-1) + h(i,j,k-2)) drho_bot(i) = drho_bot(i) + dRho_int(i,K-1) endif do_i(i) = .false. @@ -1001,14 +1016,14 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & if (hb(i) > 0.0) then N2_bot(i) = (G_Rho0 * drho_bot(i)) / hb(i) else ; N2_bot(i) = 0.0 ; endif - z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = 0.5*dz(i,nz) do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above N2_int(i,K) = N2_bot(i) @@ -1030,6 +1045,10 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo ; enddo endif + ! Average over the larger of the envelope of the topography or a minimal distance. + do i=is,ie ; dz_BBL_avg(i) = max(h_amp(i), CS%dz_BBL_avg_min) ; enddo + call find_rho_bottom(h, dz, pres, dz_BBL_avg, tv, j, G, GV, US, Rho_bot) + end subroutine find_N2 !> This subroutine sets the additional diffusivities of temperature and @@ -2172,6 +2191,10 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + call get_param(param_file, mdl, "DZ_BBL_AVG_MIN", CS%dz_BBL_avg_min, & + "A minimal distance over which to average to determine the average bottom "//& + "boundary layer density.", units="m", default=0.0, scale=US%m_to_Z) + TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) call get_param(param_file, mdl, "SIMPLE_TKE_TO_KD", CS%simple_TKE_to_Kd, & diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 89129ae480..95ffe19afb 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -157,8 +157,9 @@ module MOM_tidal_mixing ! Data containers real, allocatable :: TKE_Niku(:,:) !< Lee wave driven Turbulent Kinetic Energy input !! [R Z3 T-3 ~> W m-2] - real, allocatable :: TKE_itidal(:,:) !< The internal Turbulent Kinetic Energy input divided - !! by the bottom stratification [R Z3 T-2 ~> J m-2]. + real, allocatable :: TKE_itidal(:,:) !< The internal Turbulent Kinetic Energy input divided by + !! the bottom stratification and in non-Boussinesq mode by + !! the near-bottom density [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] real, allocatable :: Nb(:,:) !< The near bottom buoyancy frequency [T-1 ~> s-1]. real, allocatable :: mask_itidal(:,:) !< A mask of where internal tide energy is input [nondim] real, allocatable :: h2(:,:) !< Squared bottom depth variance [Z2 ~> m2]. @@ -553,8 +554,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di utide = CS%tideamp(i,j) ! Compute the fixed part of internal tidal forcing. - ! The units here are [R Z3 T-2 ~> J m-2 = kg s-2] here. - CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%Rho0 * & + ! The units here are [R Z4 H-1 T-2 ~> J m-2 or m3 s-2] here. (Note that J m-2 = kg s-2.) + CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%H_to_RZ * & CS%kappa_itides * CS%h2(i,j) * utide*utide enddo ; enddo @@ -684,14 +685,14 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', & 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) - CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale',diag%axesT1,Time, & + CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale', diag%axesT1, Time, & 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', & - 'm', conversion=US%Z_to_m) + units='m', conversion=US%Z_to_m) CS%id_Polzin_decay_scale_scaled = register_diag_field('ocean_model', & 'Polzin_decay_scale_scaled', diag%axesT1, Time, & 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme, '// & - 'scaled by N2_bot/N2_meanz', 'm', conversion=US%Z_to_m) + 'scaled by N2_bot/N2_meanz', units='m', conversion=US%Z_to_m) CS%id_N2_bot = register_diag_field('ocean_model','N2_b',diag%axesT1,Time, & 'Bottom Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2) @@ -727,16 +728,16 @@ end function tidal_mixing_init !> Depending on whether or not CVMix is active, calls the associated subroutine to compute internal !! tidal dissipation and to add the effect of internal-tide-driven mixing to the layer or interface !! diffusivities. -subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_TKE, & +subroutine calculate_tidal_mixing(dz, j, N2_bot, Rho_bot, N2_lay, N2_int, TKE_to_Kd, max_TKE, & G, GV, US, CS, Kd_max, Kv, Kd_lay, Kd_int) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy !! frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(in) :: Rho_bot !< The near-bottom in situ density [R ~> kg m-3] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the !! layers [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy frequency at the @@ -765,9 +766,9 @@ subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_T if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then - call calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) + call calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) else - call add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & + call add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, max_TKE, & G, GV, US, CS, Kd_max, Kd_lay, Kd_int) endif endif @@ -776,13 +777,12 @@ end subroutine calculate_tidal_mixing !> Calls the CVMix routines to compute tidal dissipation and to add the effect of internal-tide-driven !! mixing to the interface diffusivities. -subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) +subroutine calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy !! frequency at the interfaces [T-2 ~> s-2]. @@ -832,7 +832,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int hcorr = 0.0 ! Compute cell center depth and cell bottom in meters (negative values in the ocean) do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in the units of heights + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness @@ -920,8 +920,8 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int hcorr = 0.0 ! Compute heights at cell center and interfaces, and rescale layer thicknesses do k=1,GV%ke - h_m(k) = h(i,j,k)*GV%H_to_m ! Rescale thicknesses to m for use by CVmix. - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in the units of heights + h_m(k) = dz(i,k)*US%Z_to_m ! Rescale thicknesses to m for use by CVmix. + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness @@ -1025,16 +1025,16 @@ end subroutine calculate_CVMix_tidal !! low modes (rays) of the internal tide ("lowmode"), and (3) local dissipation of internal lee waves. !! Will eventually need to add diffusivity due to other wave-breaking processes (e.g. Bottom friction, !! Froude-number-depending breaking, PSI, etc.). -subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & +subroutine add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, max_TKE, & G, GV, US, CS, Kd_max, Kd_lay, Kd_int) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy frequency !! frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(in) :: Rho_bot !< The near-bottom in situ density [R ~> kg m-3] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the !! layers [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE @@ -1060,16 +1060,15 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! local real, dimension(SZI_(G)) :: & - htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. - htot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m]. + dztot, & ! Vertical distance between the top and bottom of the ocean [Z ~> m] + dztot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m] TKE_itidal_bot, & ! internal tide TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [H Z2 T-3 ~> m3 s-3 or W m-2] Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] - z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m]. + z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m] z0_Polzin_scaled, & ! TKE decay scale in Polzin formulation [Z ~> m]. ! multiplied by N2_bot/N2_meanz to be coherent with the WKB scaled z ! z*=int(N2/N2_bot) * N2_bot/N2_meanz = int(N2/N2_meanz) @@ -1082,19 +1081,19 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lowmode, & ! fraction of bottom TKE that should appear at top of a layer [nondim] - z_from_bot, & ! distance from bottom [Z ~> m]. - z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m]. + z_from_bot, & ! distance from bottom [Z ~> m] + z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m] real :: Kd_add ! Diffusivity to add in a layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_used ! fraction of TKE that can be used in a layer [nondim] - real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1]. - real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1]. - real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3]. + real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1] + real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1] + real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3] real :: z0Ps_denom ! The denominator of the unlimited z0_Polzin_scaled [T-3 ~> s-3]. - real :: z0_psl ! temporary variable [Z ~> m]. + real :: z0_psl ! temporary variable [Z ~> m] real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] logical :: use_Polzin, use_Simmons @@ -1104,9 +1103,9 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (.not.(CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation)) return - do i=is,ie ; htot(i) = 0.0 ; Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 ;enddo + do i=is,ie ; dztot(i) = 0.0 ; Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) + dztot(i) = dztot(i) + dz(i,k) enddo ; enddo use_Polzin = ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & @@ -1126,21 +1125,21 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%N2_bot)) & CS%dd%N2_bot(i,j) = N2_bot(i) if ( CS%Int_tide_dissipation ) then - if (Izeta*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. - Inv_int(i) = 1.0 / (1.0 - exp(-Izeta*htot(i))) + if (Izeta*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int(i) = 1.0 / (1.0 - exp(-Izeta*dztot(i))) endif endif if ( CS%Lee_wave_dissipation ) then - if (Izeta_lee*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. - Inv_int_lee(i) = 1.0 / (1.0 - exp(-Izeta_lee*htot(i))) + if (Izeta_lee*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int_lee(i) = 1.0 / (1.0 - exp(-Izeta_lee*dztot(i))) endif endif if ( CS%Lowmode_itidal_dissipation) then - if (Izeta*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. - Inv_int_low(i) = 1.0 / (1.0 - exp(-Izeta*htot(i))) + if (Izeta*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int_low(i) = 1.0 / (1.0 - exp(-Izeta*dztot(i))) endif endif - z_from_bot(i) = GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = dz(i,nz) enddo endif ! Simmons @@ -1149,109 +1148,109 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! WKB scaling of the vertical coordinate do i=is,ie ; N2_meanz(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - N2_meanz(i) = N2_meanz(i) + N2_lay(i,k) * GV%H_to_Z * h(i,j,k) + N2_meanz(i) = N2_meanz(i) + N2_lay(i,k) * dz(i,k) enddo ; enddo do i=is,ie - N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%dz_subroundoff) + N2_meanz(i) = N2_meanz(i) / (dztot(i) + GV%dz_subroundoff) if (allocated(CS%dd%N2_meanz)) & CS%dd%N2_meanz(i,j) = N2_meanz(i) enddo ! WKB scaled z*(z=H) z* at the surface using the modified Polzin WKB scaling - do i=is,ie ; htot_WKB(i) = htot(i) ; enddo -! do i=is,ie ; htot_WKB(i) = 0.0 ; enddo + do i=is,ie ; dztot_WKB(i) = dztot(i) ; enddo +! do i=is,ie ; dztot_WKB(i) = 0.0 ; enddo ! do k=1,nz ; do i=is,ie -! htot_WKB(i) = htot_WKB(i) + GV%H_to_Z*h(i,j,k) * N2_lay(i,k) / N2_meanz(i) +! dztot_WKB(i) = dztot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) ! enddo ; enddo - ! htot_WKB(i) = htot(i) ! Nearly equivalent and simpler + ! dztot_WKB(i) = dztot(i) ! Nearly equivalent and simpler do i=is,ie CS%Nb(i,j) = sqrt(N2_bot(i)) if (CS%tidal_answer_date < 20190101) then if ((CS%tideamp(i,j) > 0.0) .and. & (CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 > 1.0e-14*US%T_to_s**3) ) then - z0_polzin(i) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & + z0_Polzin(i) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & CS%Nbotref_Polzin**2 * CS%tideamp(i,j) / & ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 ) - if (z0_polzin(i) < CS%Polzin_min_decay_scale) & - z0_polzin(i) = CS%Polzin_min_decay_scale + if (z0_Polzin(i) < CS%Polzin_min_decay_scale) & + z0_Polzin(i) = CS%Polzin_min_decay_scale if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then - z0_polzin_scaled(i) = z0_polzin(i)*CS%Nb(i,j)**2 / N2_meanz(i) + z0_Polzin_scaled(i) = z0_Polzin(i)*CS%Nb(i,j)**2 / N2_meanz(i) else - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif - if (z0_polzin_scaled(i) > (CS%Polzin_decay_scale_max_factor * htot(i)) ) & - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + if (z0_Polzin_scaled(i) > (CS%Polzin_decay_scale_max_factor * dztot(i)) ) & + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) else - z0_polzin(i) = CS%Polzin_decay_scale_max_factor * htot(i) - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif else z0Ps_num = (CS%Polzin_decay_scale_factor * CS%Nu_Polzin * CS%Nbotref_Polzin**2) * CS%tideamp(i,j) z0Ps_denom = ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j) * N2_meanz(i) ) if ((CS%tideamp(i,j) > 0.0) .and. & - (z0Ps_num < z0Ps_denom * CS%Polzin_decay_scale_max_factor * htot(i))) then - z0_polzin_scaled(i) = z0Ps_num / z0Ps_denom + (z0Ps_num < z0Ps_denom * CS%Polzin_decay_scale_max_factor * dztot(i))) then + z0_Polzin_scaled(i) = z0Ps_num / z0Ps_denom - if (abs(N2_meanz(i) * z0_polzin_scaled(i)) < & - CS%Nb(i,j)**2 * (CS%Polzin_decay_scale_max_factor * htot(i))) then - z0_polzin(i) = z0_polzin_scaled(i) * (N2_meanz(i) / CS%Nb(i,j)**2) + if (abs(N2_meanz(i) * z0_Polzin_scaled(i)) < & + CS%Nb(i,j)**2 * (CS%Polzin_decay_scale_max_factor * dztot(i))) then + z0_Polzin(i) = z0_Polzin_scaled(i) * (N2_meanz(i) / CS%Nb(i,j)**2) else - z0_polzin(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif else - z0_polzin(i) = CS%Polzin_decay_scale_max_factor * htot(i) - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif endif if (allocated(CS%dd%Polzin_decay_scale)) & - CS%dd%Polzin_decay_scale(i,j) = z0_polzin(i) + CS%dd%Polzin_decay_scale(i,j) = z0_Polzin(i) if (allocated(CS%dd%Polzin_decay_scale_scaled)) & - CS%dd%Polzin_decay_scale_scaled(i,j) = z0_polzin_scaled(i) + CS%dd%Polzin_decay_scale_scaled(i,j) = z0_Polzin_scaled(i) if (allocated(CS%dd%N2_bot)) & CS%dd%N2_bot(i,j) = CS%Nb(i,j)*CS%Nb(i,j) if (CS%tidal_answer_date < 20190101) then ! These expressions use dimensional constants to avoid NaN values. if ( CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (htot_WKB(i) > 1.0e-14*US%m_to_Z) & - Inv_int(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif if ( CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09) ) then - if (htot_WKB(i) > 1.0e-14*US%m_to_Z) & - Inv_int_lee(i) = ( z0_polzin_scaled(i)*CS%Decay_scale_factor_lee / htot_WKB(i) ) + 1.0 + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int_lee(i) = ( z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee / dztot_WKB(i) ) + 1.0 endif if ( CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (htot_WKB(i) > 1.0e-14*US%m_to_Z) & - Inv_int_low(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int_low(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif else ! These expressions give values of Inv_int < 10^14 using a variant of Adcroft's reciprocal rule. Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 if ( CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (z0_polzin_scaled(i) < 1.0e14 * htot_WKB(i)) & - Inv_int(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif if ( CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09) ) then - if (z0_polzin_scaled(i) < 1.0e14 * htot_WKB(i)) & - Inv_int_lee(i) = ( z0_polzin_scaled(i)*CS%Decay_scale_factor_lee / htot_WKB(i) ) + 1.0 + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int_lee(i) = ( z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee / dztot_WKB(i) ) + 1.0 endif if ( CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (z0_polzin_scaled(i) < 1.0e14 * htot_WKB(i)) & - Inv_int_low(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int_low(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif endif - z_from_bot(i) = GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = dz(i,nz) ! Use the new formulation for WKB scaling. N2 is referenced to its vertical mean. if (CS%tidal_answer_date < 20190101) then if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then - z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz) * N2_lay(i,nz) / N2_meanz(i) + z_from_bot_WKB(i) = dz(i,nz) * N2_lay(i,nz) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif else - if (GV%H_to_Z*h(i,j,nz) * N2_lay(i,nz) < N2_meanz(i) * (1.0e14 * htot_WKB(i))) then - z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz) * N2_lay(i,nz) / N2_meanz(i) + if (dz(i,nz) * N2_lay(i,nz) < N2_meanz(i) * (1.0e14 * dztot_WKB(i))) then + z_from_bot_WKB(i) = dz(i,nz) * N2_lay(i,nz) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif endif enddo @@ -1261,7 +1260,12 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! Both Polzin and Simmons: do i=is,ie ! Dissipation of locally trapped internal tide (non-propagating high modes) - TKE_itidal_bot(i) = min(CS%TKE_itidal(i,j)*CS%Nb(i,j), CS%TKE_itide_max) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + TKE_itidal_bot(i) = min(GV%Z_to_H*CS%TKE_itidal(i,j)*CS%Nb(i,j), CS%TKE_itide_max) + else + TKE_itidal_bot(i) = min(GV%RZ_to_H*Rho_bot(i) * (CS%TKE_itidal(i,j)*CS%Nb(i,j)), & + CS%TKE_itide_max) + endif if (allocated(CS%dd%TKE_itidal_used)) & CS%dd%TKE_itidal_used(i,j) = TKE_itidal_bot(i) TKE_itidal_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) @@ -1292,7 +1296,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if ( use_Simmons ) then do k=nz-1,2,-1 ; do i=is,ie if (max_TKE(i,k) <= 0.0) cycle - z_from_bot(i) = z_from_bot(i) + GV%H_to_Z*h(i,j,k) + z_from_bot(i) = z_from_bot(i) + dz(i,k) ! Fraction of bottom flux predicted to reach top of this layer TKE_frac_top(i) = Inv_int(i) * exp(-Izeta * z_from_bot(i)) @@ -1376,26 +1380,24 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if ( use_Polzin ) then do k=nz-1,2,-1 ; do i=is,ie if (max_TKE(i,k) <= 0.0) cycle - z_from_bot(i) = z_from_bot(i) + GV%H_to_Z*h(i,j,k) + z_from_bot(i) = z_from_bot(i) + dz(i,k) if (CS%tidal_answer_date < 20190101) then if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) & - + GV%H_to_Z * h(i,j,k) * N2_lay(i,k) / N2_meanz(i) + z_from_bot_WKB(i) = z_from_bot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif else - if (GV%H_to_Z*h(i,j,k) * N2_lay(i,k) < (1.0e14 * htot_WKB(i)) * N2_meanz(i)) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) + & - GV%H_to_Z*h(i,j,k) * N2_lay(i,k) / N2_meanz(i) + if (dz(i,k) * N2_lay(i,k) < (1.0e14 * dztot_WKB(i)) * N2_meanz(i)) then + z_from_bot_WKB(i) = z_from_bot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) endif endif ! Fraction of bottom flux predicted to reach top of this layer - TKE_frac_top(i) = ( Inv_int(i) * z0_polzin_scaled(i) ) / & - ( z0_polzin_scaled(i) + z_from_bot_WKB(i) ) - z0_psl = z0_polzin_scaled(i)*CS%Decay_scale_factor_lee + TKE_frac_top(i) = ( Inv_int(i) * z0_Polzin_scaled(i) ) / & + ( z0_Polzin_scaled(i) + z_from_bot_WKB(i) ) + z0_psl = z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee TKE_frac_top_lee(i) = (Inv_int_lee(i) * z0_psl) / (z0_psl + z_from_bot_WKB(i)) - TKE_frac_top_lowmode(i) = ( Inv_int_low(i) * z0_polzin_scaled(i) ) / & - ( z0_polzin_scaled(i) + z_from_bot_WKB(i) ) + TKE_frac_top_lowmode(i) = ( Inv_int_low(i) * z0_Polzin_scaled(i) ) / & + ( z0_Polzin_scaled(i) + z_from_bot_WKB(i) ) ! Actual influx at bottom of layer minus predicted outflux at top of layer to give ! predicted power expended From 9e756afbe1b96051dcf2f06441a93e848e49f9d8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 12 Aug 2023 06:36:07 -0400 Subject: [PATCH 047/146] *Fix allocate_forcing_by_ref tau_mag_gustless bug Added the name to the do_taumag argument in a call to allocate_forcing_type in allocate_forcing_by_ref to account for the fact that there are unused wave-related optional arguments in this interface. When this was omitted in the current code, the wrong arrays are being allocated during rotation tests with resultant segmentation faults in those tests. This commit corrects a bug that was recently added with MOM6 dev/gfdl PR #445. --- src/core/MOM_forcing_type.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index c86b9b869f..f4e9960cd8 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -3331,7 +3331,7 @@ subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) call allocate_forcing_type(G, fluxes, do_water, do_heat, do_ustar, & - do_press, do_shelf, do_iceberg, do_salt, do_taumag) + do_press, do_shelf, do_iceberg, do_salt, tau_mag=do_taumag) ! The following fluxes would typically be allocated by the driver call myAlloc(fluxes%sw_vis_dir, G%isd, G%ied, G%jsd, G%jed, & From 2642c1cb6e202e42a857323f76fa70a2b03fbb90 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 14 Jun 2023 02:29:38 -0400 Subject: [PATCH 048/146] Fix rescaling in regularize_surface debugging Add missing dimensional rescaling factors for hard-coded temperature and salinity offsets in debugging conservation checks in regularize_surface. All answers are bitwise identical, but without this change some configurations can erroneously give fatal errors for some rescaling settings when DEBUG=True. --- src/parameterizations/vertical/MOM_regularize_layers.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 2f2c66eca7..d4034d699c 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -576,14 +576,14 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) trim(mesg), .true.) fatal_error = .true. endif - if (abs(Th_tot1(i) - Th_tot2(i)) > 1e-12*(Th_tot1(i)+10.0*h_tot1(i))) then + if (abs(Th_tot1(i) - Th_tot2(i)) > 1e-12*abs(Th_tot1(i) + 10.0*US%degC_to_C*h_tot1(i))) then write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') & Th_tot1(i), Th_tot2(i), (Th_tot1(i) - Th_tot2(i)), (Th_tot1(i) - Th_tot3(i)) call MOM_error(WARNING, "regularize_surface: Heat non-conservation."//& trim(mesg), .true.) fatal_error = .true. endif - if (abs(Sh_tot1(i) - Sh_tot2(i)) > 1e-12*(Sh_tot1(i)+10.0*h_tot1(i))) then + if (abs(Sh_tot1(i) - Sh_tot2(i)) > 1e-12*abs(Sh_tot1(i) + 10.0*US%ppt_to_S*h_tot1(i))) then write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') & Sh_tot1(i), Sh_tot2(i), (Sh_tot1(i) - Sh_tot2(i)), (Sh_tot1(i) - Sh_tot3(i)) call MOM_error(WARNING, "regularize_surface: Salinity non-conservation."//& From f847b3cfd4c6732d65b399d030ea0805df107b98 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Aug 2023 14:46:44 -0400 Subject: [PATCH 049/146] *Non-Boussinesq revision of 3 MOM_CVMix modules This commit revises MOM_CVMix_conv, MOM_CVMix_ddiff and MOM_CVMix_shear to work in an appropriate mixture of thickness and vertical extent variables to enable their use in non-Boussinesq mode, using thickness_to_dz to convert between the two, while retaining the previous answers in Boussinesq mode. This includes the use of a layer thicknesses rather than a vertical distance in the denominator of the calculation of the buoyancy frequency and to the units of the internal rescaled gravity variable in CVMix_conv. This commit eliminates any direct or indirect dependency on the Boussinesq reference density in these 3 modules when in non-Boussinesq mode. This set of changes includes changing the units of 7 internal variables and the addition, renaming, or change in the dimensions of 4 internal variables. One element in the CVMix_ddiff_cs type is rescaled to use thickness units. These changes lead to the removal of 4 factors of GV%H_to_Z in these 3 modules. Answers will change in non-Boussinesq mode when USE_CVMix_CONVECTION, USE_CVMIX_DDIFF, USE_PP81 or USE_LMD94 are true, but they are bitwise identical in all Boussinesq test cases. --- .../vertical/MOM_CVMix_conv.F90 | 36 +++++++++++-------- .../vertical/MOM_CVMix_ddiff.F90 | 18 +++++----- .../vertical/MOM_CVMix_shear.F90 | 20 ++++++++--- 3 files changed, 46 insertions(+), 28 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index c95b967681..19744cb6c5 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -11,6 +11,7 @@ module MOM_CVMix_conv use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -163,23 +164,27 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) real, dimension(SZK_(GV)+1) :: N2 !< Squared buoyancy frequency [s-2] real, dimension(SZK_(GV)+1) :: kv_col !< Viscosities at interfaces in the column [m2 s-1] real, dimension(SZK_(GV)+1) :: kd_col !< Diffusivities at interfaces in the column [m2 s-1] - real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [m] - real, dimension(SZK_(GV)) :: cellHeight !< Height of cell centers [m] + real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [Z ~> m] + real, dimension(SZK_(GV)) :: cellHeight !< Height of cell centers [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & kd_conv, & !< Diffusivity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] kv_conv, & !< Viscosity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] N2_3d !< Squared buoyancy frequency for diagnostics [T-2 ~> s-2] integer :: kOBL !< level of ocean boundary layer extent - real :: g_o_rho0 ! Gravitational acceleration divided by density times unit conversion factors - ! [Z s-2 R-1 ~> m4 s-2 kg-1] + real :: g_o_rho0 ! Gravitational acceleration, perhaps divided by density, times unit conversion factors + ! [H s-2 R-1 ~> m4 s-2 kg-1 or m s-2] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: rhok, rhokm1 ! In situ densities of the layers above and below at the interface pressure [R ~> kg m-3] - real :: hbl_KPP ! The depth of the ocean boundary as used by KPP [m] - real :: dz ! A thickness [Z ~> m] + real :: dh_int ! The distance between layer centers [H ~> m or kg m-2] real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] integer :: i, j, k - g_o_rho0 = US%L_to_Z**2*US%s_to_T**2 * GV%g_Earth / GV%Rho0 + if (GV%Boussinesq) then + g_o_rho0 = (US%L_to_Z**2*US%s_to_T**2*GV%Z_to_H) * GV%g_Earth / GV%Rho0 + else + g_o_rho0 = (US%L_to_Z**2*US%s_to_T**2*GV%RZ_to_H) * GV%g_Earth + endif ! initialize dummy variables rho_lwr(:) = 0.0 ; rho_1d(:) = 0.0 @@ -192,6 +197,10 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) if (CS%id_kd_conv > 0) Kd_conv(:,:,:) = 0.0 do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i = G%isc, G%iec ! skip calling at land points @@ -206,8 +215,8 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) call calculate_density(tv%t(i,j,k), tv%s(i,j,k), pRef, rhok, tv%eqn_of_state) call calculate_density(tv%t(i,j,k-1), tv%s(i,j,k-1), pRef, rhokm1, tv%eqn_of_state) - dz = ((0.5*(h(i,j,k-1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z) - N2(K) = g_o_rho0 * (rhok - rhokm1) / dz ! Can be negative + dh_int = 0.5*(h(i,j,k-1) + h(i,j,k)) + GV%H_subroundoff + N2(K) = g_o_rho0 * (rhok - rhokm1) / dh_int ! Can be negative enddo @@ -215,17 +224,16 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) hcorr = 0.0 ! compute heights at cell center and interfaces do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in the units of heights + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh - iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh enddo ! gets index of the level and interface above hbl - hbl_KPP = US%Z_to_m*hbl(i,j) ! Convert to the units used by CVMix. - kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl_KPP) + kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl(i,j)) kv_col(:) = 0.0 ; kd_col(:) = 0.0 call CVMix_coeffs_conv(Mdiff_out=kv_col(:), & diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index c2bf357559..af17e0287f 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -35,7 +35,7 @@ module MOM_CVMix_ddiff real :: kappa_ddiff_param1 !< exterior coefficient in diffusive convection regime [nondim] real :: kappa_ddiff_param2 !< middle coefficient in diffusive convection regime [nondim] real :: kappa_ddiff_param3 !< interior coefficient in diffusive convection regime [nondim] - real :: min_thickness !< Minimum thickness allowed [Z ~> m] + real :: min_thickness !< Minimum thickness allowed [H ~> m or kg-2] character(len=4) :: diff_conv_type !< type of diffusive convection to use. Options are Marmorino & !! Caldwell 1976 ("MC76"; default) and Kelley 1988, 1990 ("K90") logical :: debug !< If true, turn on debugging @@ -83,7 +83,7 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & - units="m", scale=US%m_to_Z, default=0.001, do_not_log=.True.) + units="m", scale=GV%m_to_H, default=0.001, do_not_log=.True.) call openParameterBlock(param_file,'CVMIX_DDIFF') @@ -162,7 +162,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) ! Local variables real, dimension(SZK_(GV)) :: & - cellHeight, & !< Height of cell centers [m] + cellHeight, & !< Height of cell centers relative to the sea surface [H ~> m or kg m-2] dRho_dT, & !< partial derivatives of density with temperature [R C-1 ~> kg m-3 degC-1] dRho_dS, & !< partial derivatives of density with salinity [R S-1 ~> kg m-3 ppt-1] pres_int, & !< pressure at each interface [R L2 T-2 ~> Pa] @@ -176,8 +176,8 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) Kd1_T, & !< Diapycanal diffusivity of temperature [m2 s-1]. Kd1_S !< Diapycanal diffusivity of salinity [m2 s-1]. - real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [m] - real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] + real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces relative to the sea surface [H ~> m or kg m-2] + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [H ~> m or kg m-2] integer :: i, k ! initialize dummy variables @@ -237,16 +237,16 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) hcorr = 0.0 ! compute heights at cell center and interfaces do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in height units + dh = h(i,j,k) ! Nominal thickness to use for increment, in height units dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh - iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh enddo ! gets index of the level and interface above hbl - !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl(i,j)) + !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, GV%Z_to_H*hbl(i,j)) Kd1_T(:) = 0.0 ; Kd1_S(:) = 0.0 call CVMix_coeffs_ddiff(Tdiff_out=Kd1_T(:), & diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 2e23787555..829318b606 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -10,6 +10,7 @@ module MOM_CVMix_shear use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -76,11 +77,12 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) real :: GoRho ! Gravitational acceleration divided by density [Z T-2 R-1 ~> m4 s-2 kg-1] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: DU, DV ! Velocity differences [L T-1 ~> m s-1] - real :: DZ ! Grid spacing around an interface [Z ~> m] + real :: dz_int ! Grid spacing around an interface [Z ~> m] real :: N2 ! Buoyancy frequency at an interface [T-2 ~> s-2] real :: S2 ! Shear squared at an interface [T-2 ~> s-2] real :: dummy ! A dummy variable [nondim] real :: dRho ! Buoyancy differences [Z T-2 ~> m s-2] + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] real, dimension(2*(GV%ke)) :: pres_1d ! A column of interface pressures [R L2 T-2 ~> Pa] real, dimension(2*(GV%ke)) :: temp_1d ! A column of temperatures [C ~> degC] real, dimension(2*(GV%ke)) :: salt_1d ! A column of salinities [S ~> ppt] @@ -96,6 +98,10 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) epsln = 1.e-10 * GV%m_to_H do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i = G%isc, G%iec ! skip calling for land points @@ -132,10 +138,14 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) kk = 2*(k-1) DU = u_h(i,j,k) - u_h(i,j,km1) DV = v_h(i,j,k) - v_h(i,j,km1) - DRHO = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) - DZ = (0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z - N2 = DRHO / DZ - S2 = US%L_to_Z**2*(DU*DU+DV*DV)/(DZ*DZ) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + dRho = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) + else + dRho = (US%L_to_Z**2 * GV%g_Earth) * (rho_1D(kk+1) - rho_1D(kk+2)) / (0.5*(rho_1D(kk+1) + rho_1D(kk+2))) + endif + dz_int = 0.5*(dz(i,km1) + dz(i,k)) + GV%dZ_subroundoff + N2 = DRHO / dz_int + S2 = US%L_to_Z**2*(DU*DU + DV*DV) / (dz_int*dz_int) Ri_Grad(k) = max(0., N2) / max(S2, 1.e-10*US%T_to_s**2) ! fill 3d arrays, if user asks for diagnostics From 22a370c56fa8d14c4cd6bd418865175b679aa35c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 7 Aug 2023 04:46:09 -0400 Subject: [PATCH 050/146] *Non-Boussinesq revision of MOM_CVMix_KPP This commit revises MOM_CVMix_KPP to work in an appropriate mixture of thickness and vertical extent variables to enable their use in non-Boussinesq mode, using thickness_to_dz to convert between the two, while retaining the previous answers in Boussinesq mode. This includes the use of a layer thicknesses rather than a vertical distance in the denominator of the calculation of the buoyancy frequency and the replacement of the layer thickness argument (h) to KPP_smooth_BLD with a layer vertical extent (dz). When in non-Boussinesq mode, the buoyancy difference between layers is normalized by the average of the density of the two layers rather than the Boussinesq reference density. This commit eliminates any direct or indirect dependency on the Boussinesq reference density in CVMix_KPP when in non-Boussinesq mode. This set of changes includes changing the units of 1 internal variables and the addition of 2 new internal variables, and a change to the name and units of one argument to KPP_smooth_BLD. These changes lead to the removal of 5 factors of GV%H_to_Z. Answers will change in non-Boussinesq mode when USE_KPP is true, but they are bitwise identical in all Boussinesq test cases. --- .../vertical/MOM_CVMix_KPP.F90 | 54 ++++++++++++------- 1 file changed, 35 insertions(+), 19 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index d24c3e2954..303e41fc3d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -625,6 +625,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & ! Local variables integer :: i, j, k ! Loop indices + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] (negative in ocean) real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] (negative in ocean) real, dimension( GV%ke ) :: z_cell ! Cell center heights referenced to surface [m] (negative in ocean) @@ -663,13 +664,17 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & buoy_scale = US%L_to_m**2*US%s_to_T**3 !$OMP parallel do default(none) firstprivate(nonLocalTrans) & - !$OMP private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !$OMP private(surfFricVel, iFaceHeight, hcorr, dh, dz, cellHeight, & !$OMP surfBuoyFlux, Kdiffusivity, Kviscosity, LangEnhK, sigma, & !$OMP sigmaRatio, z_inter, z_cell) & - !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, Kt, & + !$OMP shared(G, GV, CS, US, tv, uStar, h, buoy_scale, buoyFlux, Kt, & !$OMP Ks, Kv, nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) ! loop over horizontal points on processor do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then ! things independent of position within the column @@ -680,7 +685,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment + dh = dz(i,k) ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness @@ -930,6 +935,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! Variables for passing to CVMix routines, often in MKS units real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars in MKS units [m s-1] real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] + real, dimension( GV%ke ) :: deltaBuoy ! Change in Buoyancy based on deltaRho [m s-2] real, dimension( GV%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] real, dimension( GV%ke ) :: surfBuoyFlux2 ! Surface buoyancy flux in MKS units [m2 s-3] real, dimension( GV%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer [nondim] @@ -954,8 +960,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real, dimension( GV%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [T-2 ~> s-2] real :: zBottomMinusOffset ! Height of bottom plus a little bit [Z ~> m] real :: GoRho ! Gravitational acceleration in MKS units divided by density [m s-2 R-1 ~> m4 kg-1 s-2] - real :: GoRho_Z_L2 ! Gravitational acceleration divided by density times aspect ratio - ! rescaling [Z T-2 R-1 ~> m4 kg-1 s-2] + real :: GoRho_Z_L2 ! Gravitational acceleration, perhaps divided by density, times aspect ratio + ! rescaling [H T-2 R-1 ~> m4 kg-1 s-2 or m s-2] real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] real :: Uk, Vk ! Layer velocities relative to their averages in the surface layer [L T-1 ~> m s-1] real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth [Z ~> m] @@ -994,8 +1000,12 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl call cpu_clock_begin(id_clock_KPP_compute_BLD) ! some constants - GoRho_Z_L2 = US%L_to_Z**2 * GV%g_Earth / GV%Rho0 - GoRho = US%Z_to_m*US%s_to_T**2 * GoRho_Z_L2 + GoRho = US%Z_to_m*US%s_to_T**2 * (US%L_to_Z**2 * GV%g_Earth / GV%Rho0) + if (GV%Boussinesq) then + GoRho_Z_L2 = US%L_to_Z**2 * GV%Z_to_H * GV%g_Earth / GV%Rho0 + else + GoRho_Z_L2 = US%L_to_Z**2 * GV%g_Earth * GV%RZ_to_H + endif buoy_scale = US%L_to_m**2*US%s_to_T**3 ! Find the vertical distances across layers. @@ -1008,7 +1018,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, N_col, & !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_guess, LA, rho_1D, & - !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & + !$OMP deltarho, deltaBuoy, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & !$OMP z_inter, OBL_depth, BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, dz, buoy_scale, buoyFlux, & !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult) @@ -1037,7 +1047,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment + dh = dz(i,j,k) ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness @@ -1066,7 +1076,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl do ktmp = 1,ksfc ! SLdepth_0d can be between cell interfaces - delH = min( max(0.0, SLdepth_0d - hTot), h(i,j,ktmp)*GV%H_to_Z ) + delH = min( max(0.0, SLdepth_0d - hTot), dz(i,j,ktmp) ) ! surface layer thickness hTot = hTot + delH @@ -1147,8 +1157,14 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl km1 = max(1, k-1) kk = 3*(k-1) deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + deltaBuoy(k) = GoRho*(rho_1D(kk+2) - rho_1D(kk+1)) + else + deltaBuoy(k) = (US%Z_to_m*US%s_to_T**2) * (US%L_to_Z**2 * GV%g_Earth) * & + ( (rho_1D(kk+2) - rho_1D(kk+1)) / (0.5 * (rho_1D(kk+2) + rho_1D(kk+1))) ) + endif N2_1d(k) = (GoRho_Z_L2 * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & - ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z) + ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)) CS%N(i,j,k) = sqrt( max( N2_1d(k), 0.) ) enddo N2_1d(GV%ke+1 ) = 0.0 @@ -1202,7 +1218,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! Calculate Bulk Richardson number from eq (21) of LMD94 BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & zt_cntr=z_cell, & ! Depth of cell center [m] - delta_buoy_cntr=GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) [m s-2] + delta_buoy_cntr=deltaBuoy, & ! Bulk buoyancy difference, Br-B(z) [m s-2] delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference [m2 s-2] ws_cntr=Ws_1d, & ! Turbulent velocity scale profile [m s-1] N_iface=N_col, & ! Buoyancy frequency [s-1] @@ -1256,7 +1272,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !BGR consider if LTEnhancement is wanted for diagnostics if (CS%id_Ws > 0) then call CVMix_kpp_compute_turbulent_scales( & - -cellHeight(:)/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate + -cellHeight(:)/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate [nondim] US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] @@ -1296,19 +1312,19 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) ! BLD smoothing: - if (CS%n_smooth > 0) call KPP_smooth_BLD(CS, G, GV, US, h) + if (CS%n_smooth > 0) call KPP_smooth_BLD(CS, G, GV, US, dz) end subroutine KPP_compute_BLD !> Apply a 1-1-4-1-1 Laplacian filter one time on BLD to reduce any horizontal two-grid-point noise -subroutine KPP_smooth_BLD(CS, G, GV, US, h) +subroutine KPP_smooth_BLD(CS, G, GV, US, dz) ! Arguments type(KPP_CS), pointer :: CS !< Control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: dz !< Layer thicknesses [Z ~> m] ! local real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration [Z ~> m] @@ -1333,7 +1349,7 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, h) OBLdepth_prev = CS%OBLdepth ! apply smoothing on OBL depth - !$OMP parallel do default(none) shared(G, GV, US, CS, h, OBLdepth_prev) & + !$OMP parallel do default(none) shared(G, GV, US, CS, dz, OBLdepth_prev) & !$OMP private(wc, ww, we, wn, ws, dh, hcorr, cellHeight, iFaceHeight) do j = G%jsc, G%jec do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then @@ -1343,7 +1359,7 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, h) do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment + dh = dz(i,j,k) ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness From c80390451296812d4903baceb526633bcde68592 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Mon, 14 Aug 2023 17:03:54 -0400 Subject: [PATCH 051/146] Bugfix for MOM_tracer_advect for ad_x/y and ad2d_x/y diagnostic fields - Tracer advection diagnostics in symmetric mode had errors at processor boundaries because they were computed over only the tracer indices. The tracer advection diagnostics have been updated to compute over a range of indices identical to the fluxes, which allows it to also work on the u/v point indices in both non-symmetric and symmetric mode. - These code updates only impact the tracer diagnostics, and in no cases were the model solutions impacted by the bug outside of these select diagnostic fields. - The corrected diagnostics reproduce the old non-symmetric mode results in both symmetric and non-symmetric mode. - Some logic has been updated and comments were added to improve the code, but none of these changes impact the model solution. --- src/tracer/MOM_tracer_advect.F90 | 45 ++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 20 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 5abca6e578..dde110f959 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -655,7 +655,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & enddo ! diagnostics - if (associated(Tr(m)%ad_x)) then ; do i=is,ie ; if (do_i(i,j)) then + if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j)) then Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt endif ; enddo ; endif @@ -682,13 +682,13 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! compute ad2d_x diagnostic outside above j-loop so as to make the summation ordered when OMP is active. !$OMP ordered - do j=js,je ; if (domore_u_initial(j,k)) then - do m=1,ntr - if (associated(Tr(m)%ad2d_x)) then ; do i=is,ie ; if (do_i(i,j)) then + do m=1,ntr ; if (associated(Tr(m)%ad2d_x)) then + do j=js,je ; if (domore_u_initial(j,k)) then + do I=is-1,ie ; if (do_i(i,j)) then Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt - endif ; enddo ; endif - enddo - endif ; enddo ! End of j-loop. + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. !$OMP end ordered end subroutine advect_x @@ -756,6 +756,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & logical :: usePLMslope integer :: i, j, j2, m, n, j_up, stencil type(OBC_segment_type), pointer :: segment=>NULL() + logical :: domore_v_initial(SZJB_(G)) ! Initial state of domore_v usePLMslope = .not. (usePPM .and. useHuynh) ! stencil for calculating slope values @@ -778,6 +779,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! this would require an additional loop, etc. do_j_tr(:) = .false. do J=js-1,je ; if (domore_v(J,k)) then ; do j2=1-stencil,stencil ; do_j_tr(j+j2) = .true. ; enddo ; endif ; enddo + domore_v_initial(:) = domore_v(:,k) ! Calculate the j-direction profiles (slopes) of each tracer that ! is being advected. @@ -1034,11 +1036,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & (flux_y(i,m,J) - flux_y(i,m,J-1))) * Ihnew(i) endif ; enddo - ! diagnostics - if (associated(Tr(m)%ad_y)) then ; do i=is,ie ; if (do_i(i,j)) then - Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt - endif ; enddo ; endif - ! diagnose convergence of flux_y and add to convergence of flux_x. ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. if (associated(Tr(m)%advection_xy)) then @@ -1058,16 +1055,24 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & enddo ; enddo endif ; enddo - ! compute ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active. - + ! compute ad_y and ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active. !$OMP ordered - do j=js,je ; if (do_j_tr(j)) then - do m=1,ntr - if (associated(Tr(m)%ad2d_y)) then ; do i=is,ie ; if (do_i(i,j)) then + do m=1,ntr ; if (associated(Tr(m)%ad_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + ! (The logical test could be "do_i(i,j) .or. do_i(i+1,j)" to be clearer, but not needed) + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. + + do m=1,ntr ; if (associated(Tr(m)%ad2d_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + do i=is,ie ; if (do_i(i,j)) then Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt - endif ; enddo ; endif - enddo - endif ; enddo ! End of j-loop. + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. !$OMP end ordered end subroutine advect_y From a8088819a223a939f6a63150d3804c82147b7aa5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 16 Jun 2023 10:34:44 -0400 Subject: [PATCH 052/146] *Non-Boussinesq interface_filter Refactored interface_filter when in non-Boussinesq mode to avoid any dependencies on the Boussinesq reference density, and to translate the volume streamfunction into the mass streamfunction using an appropriately defined in-situ density averaged to the interfaces at velocity points. This form is similar to the one that is used in thickness_diffuse. No public interfaces are changed, and all answers are bitwise identical in Boussinesq or semiBoussinesq mode, but they will change in non-Boussinesq mode cases that use the interface filter. --- .../lateral/MOM_interface_filter.F90 | 48 +++++++++++++++---- 1 file changed, 38 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/lateral/MOM_interface_filter.F90 b/src/parameterizations/lateral/MOM_interface_filter.F90 index dd082f1558..07b698e294 100644 --- a/src/parameterizations/lateral/MOM_interface_filter.F90 +++ b/src/parameterizations/lateral/MOM_interface_filter.F90 @@ -148,7 +148,7 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) endif ! Calculate uhD, vhD from h, e, Lsm2_u, Lsm2_v - call filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size=filter_itts-1) + call filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size=filter_itts-1) do itt=2,filter_itts @@ -156,14 +156,23 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) !$OMP parallel do default(shared) do j=js-hs,je+hs do i=is-hs,ie+hs ; de_smooth(i,j,nz+1) = 0.0 ; enddo - do k=nz,1,-1 ; do i=is-hs,ie+hs - de_smooth(i,j,k) = de_smooth(i,j,k+1) + GV%H_to_Z * G%IareaT(i,j) * & - ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) - enddo ; enddo + + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + do k=nz,1,-1 ; do i=is-hs,ie+hs + de_smooth(i,j,K) = de_smooth(i,j,K+1) + (GV%H_to_RZ * tv%SpV_avg(i,j,k)) * G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + enddo ; enddo + else + do k=nz,1,-1 ; do i=is-hs,ie+hs + de_smooth(i,j,K) = de_smooth(i,j,K+1) + GV%H_to_Z * G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + enddo ; enddo + endif enddo ! Calculate uhD, vhD from h, de_smooth, Lsm2_u, Lsm2_v - call filter_interface(h, de_smooth, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size=filter_itts-itt) + call filter_interface(h, de_smooth, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size=filter_itts-itt) enddo ! Offer diagnostic fields for averaging. This must occur before updating the layer thicknesses @@ -227,7 +236,7 @@ end subroutine interface_filter !> Calculates parameterized layer transports for use in the continuity equation. !! Fluxes are limited to give positive definite thicknesses. !! Called by interface_filter(). -subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size) +subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size) 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 @@ -241,6 +250,7 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size !! [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vhD !< Meridional mass fluxes !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure integer, optional, intent(in) :: halo_size !< The size of the halo to work on, !! 0 by default. @@ -256,14 +266,16 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size real :: Sfn_est ! A preliminary estimate (before limiting) of the overturning ! streamfunction [H L2 ~> m3 or kg]. real :: Sfn ! The overturning streamfunction [H L2 ~> m3 or kg]. + real :: Rho_avg ! The in situ density averaged to an interface [R ~> kg m-3] 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 :: hn_2 ! Half of h_neglect [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz, hs hs = 0 ; if (present(halo_size)) hs = halo_size is = G%isc-hs ; ie = G%iec+hs ; js = G%jsc-hs ; je = G%jec+hs ; nz = GV%ke - h_neglect = GV%H_subroundoff + h_neglect = GV%H_subroundoff ; hn_2 = 0.5*h_neglect ! Find the maximum and minimum permitted streamfunction. !$OMP parallel do default(shared) @@ -286,7 +298,15 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size do I=is-1,ie Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j) - Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%Z_to_H * Slope) + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i+1,j,k) + h(i+1,j,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k) + (h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1)) ) + Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%RZ_to_H * Slope) * Rho_avg + else + Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%Z_to_H * Slope) + endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. @@ -318,7 +338,15 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size do i=is,ie Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J) - Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%Z_to_H * Slope) + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i,j+1,k) + h(i,j+1,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k) + (h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1)) ) + Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%RZ_to_H * Slope) * Rho_avg + else + Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%Z_to_H * Slope) + endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. From d223f25396211a9237c2e67b4ce61c06059e9948 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 8 Jun 2023 10:10:36 -0400 Subject: [PATCH 053/146] *Revise calc_isoneutral_slopes when non-Boussinesq Revise calc_isoneutral_slopes to eliminate any dependence on the Boussinesq reference density when in non-Boussinesq mode. This includes the addition of two new arrays to hold the rescaled product of the gravitational acceleration and the specific volume interpolated to the interfaces at velocity points. The answers change in non-Boussinesq mode when one of several parameterizations that use the isoneutral slopes are in use, but are bitwise identical in Boussinesq or semi-Boussinesq mode. --- src/core/MOM_isopycnal_slopes.F90 | 60 ++++++++++++++++++++++++++----- 1 file changed, 52 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 29c547148d..5aa78cb87a 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -4,6 +4,7 @@ module MOM_isopycnal_slopes ! This file is part of MOM6. See LICENSE.md for the license. use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, FATAL use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -81,10 +82,14 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan real, dimension(SZIB_(G)) :: & T_u, & ! Temperature on the interface at the u-point [C ~> degC]. S_u, & ! Salinity on the interface at the u-point [S ~> ppt]. + GxSpV_u, & ! Gravitiational acceleration times the specific volume at an interface + ! at the u-points [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] pres_u ! Pressure on the interface at the u-point [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: & T_v, & ! Temperature on the interface at the v-point [C ~> degC]. S_v, & ! Salinity on the interface at the v-point [S ~> ppt]. + GxSpV_v, & ! Gravitiational acceleration times the specific volume at an interface + ! at the v-points [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: & T_h, & ! Temperature on the interface at the h-point [C ~> degC]. @@ -202,6 +207,17 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif endif + if ((use_EOS .and. allocated(tv%SpV_avg) .and. (tv%valid_SpV_halo < 1)) .and. & + (present_N2_u .or. present(dzSxN) .or. present_N2_v .or. present(dzSyN))) then + if (tv%valid_SpV_halo < 0) then + call MOM_error(FATAL, "calc_isoneutral_slopes called in fully non-Boussinesq mode "//& + "with invalid values of SpV_avg.") + else + call MOM_error(FATAL, "calc_isoneutral_slopes called in fully non-Boussinesq mode "//& + "with insufficiently large SpV_avg halos of width 0 but 1 is needed.") + endif + endif + ! Find the maximum and minimum permitted streamfunction. if (associated(tv%p_surf)) then !$OMP parallel do default(shared) @@ -227,7 +243,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan !$OMP local_open_u_BC,dzu,OBC,use_stanley) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_u, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdx,mag_grad2,slope,l_seg) do j=js,je ; do K=nz,2,-1 @@ -245,6 +261,18 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & tv%eqn_of_state, EOSdom_u) + if (present_N2_u .or. (present(dzSxN))) then + if (allocated(tv%SpV_avg)) then + do I=is-1,ie + GxSpV_u(I) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + & + (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i+1,j,k-1))) + enddo + else + do I=is-1,ie + GxSpV_u(I) = G_Rho0 + enddo + endif + endif endif if (use_stanley) then @@ -308,7 +336,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) ! This is the gradient of density along geopotentials. - if (present_N2_u) N2_u(I,j,K) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + if (present_N2_u) then + N2_u(I,j,K) = GxSpV_u(I) * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + endif if (use_EOS) then drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & @@ -343,8 +373,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif slope_x(I,j,K) = slope if (present(dzSxN)) & - dzSxN(I,j,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + dzSxN(I,j,K) = sqrt( GxSpV_u(I) * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 enddo ! I @@ -357,7 +387,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan !$OMP dzv,local_open_v_BC,OBC,use_stanley) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_v, & !$OMP drho_dT_dT_hr,pres_hr,T_hr,S_hr, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdy,mag_grad2,slope,l_seg) @@ -375,7 +405,21 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & tv%eqn_of_state, EOSdom_v) + + if ((present_N2_v) .or. (present(dzSyN))) then + if (allocated(tv%SpV_avg)) then + do i=is,ie + GxSpV_v(i) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + & + (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j+1,k-1))) + enddo + else + do i=is,ie + GxSpV_v(i) = G_Rho0 + enddo + endif + endif endif + if (use_stanley) then do i=is,ie pres_h(i) = pres(i,j,K) @@ -443,7 +487,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) ! This is the gradient of density along geopotentials. - if (present_N2_v) N2_v(i,J,K) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + if (present_N2_v) N2_v(i,J,K) = GxSpV_v(i) * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] if (use_EOS) then drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & @@ -480,8 +524,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif slope_y(i,J,K) = slope if (present(dzSyN)) & - dzSyN(i,J,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + dzSyN(i,J,K) = sqrt( GxSpV_v(i) * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 enddo ! i From d16f343e42615d09761dc50aaca268b60a7ca504 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 31 May 2023 05:45:32 -0400 Subject: [PATCH 054/146] Refactor rescaling of CFC_cap flux diagnostics Rescaled CFC flux diagnostics in the CFC cap via a conversion factor in their register diag_field calls, rather than by doing array syntax math in their post_data calls. All answers are bitwise identical. --- src/tracer/MOM_CFC_cap.F90 | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index ef8e712b7a..becf1f8995 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -190,7 +190,7 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type !! specifies whether, where, and what !! open boundary conditions are used. - type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. ! local variables @@ -215,7 +215,7 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) ! CFC12 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/3ab8e10027d7014f18f9391890369235.html write(m2char, "(I1)") m CS%CFC_data(m)%id_cmor = register_diag_field('ocean_model', 'cfc1'//m2char, diag%axesTL, day, & - 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3') + 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3', conversion=GV%Rho0*US%R_to_kg_m3) enddo @@ -308,7 +308,6 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real :: flux_scale integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -318,14 +317,12 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Compute KPP nonlocal term if necessary if (present(KPP_CSp)) then if (associated(KPP_CSp) .and. present(nonLocalTrans)) then - flux_scale = GV%Z_to_H / GV%rho0 - call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%cfc11_flux(:,:), dt, CS%diag, & CS%CFC_data(1)%tr_ptr, CS%CFC_data(1)%conc(:,:,:), & - flux_scale=flux_scale) + flux_scale=GV%RZ_to_H) call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%cfc12_flux(:,:), dt, CS%diag, & CS%CFC_data(2)%tr_ptr, CS%CFC_data(2)%conc(:,:,:), & - flux_scale=flux_scale) + flux_scale=GV%RZ_to_H) endif endif @@ -351,12 +348,8 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C endif ! If needed, write out any desired diagnostics from tracer sources & sinks here. - if (CS%CFC_data(1)%id_cmor > 0) call post_data(CS%CFC_data(1)%id_cmor, & - (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(1)%conc, & - CS%diag) - if (CS%CFC_data(2)%id_cmor > 0) call post_data(CS%CFC_data(2)%id_cmor, & - (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(2)%conc, & - CS%diag) + if (CS%CFC_data(1)%id_cmor > 0) call post_data(CS%CFC_data(1)%id_cmor, CS%CFC_data(1)%conc, CS%diag) + if (CS%CFC_data(2)%id_cmor > 0) call post_data(CS%CFC_data(2)%id_cmor, CS%CFC_data(2)%conc, CS%diag) end subroutine CFC_cap_column_physics From 546728a23d0fd0c56126ba18e5c3e748a41f6bb5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Aug 2023 05:54:12 -0400 Subject: [PATCH 055/146] *+Non-Boussinesq revision of set_viscosity This commit revises set_viscous_BBL and set_viscous_ML to work in fully non-Boussinesq mode, eliminating all dependencies on the Boussinesq reference density when in non-Boussinesq mode. These changes include using the specific volume interpolated to velocity points for the conversion between thickness and height changes when tv%SpV_avg is allocated, including in the calculation of the rescaled ustar in the top and bottom boundary layers and in the Rayleigh drag calculation. In set_viscous_ML, the derivatives of specific volume are used to determine the reduced gravity across interfaces when in non-Boussinesq mode. Both set_viscous_BBL and set_viscous_ML now work extensively in height units rather than thickness units in various places where it is more appropriate to do so when in non-Boussinesq mode, and both use calls to thickness_to_dz to convert between thicknesses and vertical distances. In some places this leads to extra calculations using separate arrays that are rescaled duplicates of each other in Boussinesq mode, which will probably slow the model down a little. There is one rescaling bug due to a hard-coded unrescaled dimensional constant that was fixed. It occurs when setting a tiny floor in a thickness in one inverse calculation. However, this appears to be so small that it does not change any answers in the MOM6-examples test suite, and could only do so if ANGSTROM is set to be many orders of magnitude less than the typical value of 1e-10 m, so it was decided that no runtime bug-flag is needed in this case. A call to find_star is now used to specify the friction velocity used in set_viscous_ML. When in non-Boussinesq mode, this has the effect of using forces%tau_mag and tv%SpV_avg instead of forces%ustar and GV%Rho0 to determine the friction velocity. In set_viscous_BBL the layer specific volumes are used in non-Boussinesq mode to find the average velocities used in the linearization of the nonlinear bottom drag, with similar changes in set_viscous_ML for the drag under ice-shelves. When in non-Boussinesq mode, the units of Kd_shear, Kv_shear and Kv_shear_Bu in the restart files are scaled to their natural MKS units of [Pa s] or [kg m-1 s-1] rather than [m2 s-1] to avoid round-off level changes across restarts, with the units in the files documenting these changes. These altered units do not apply to Boussinesq mode restart files. In set_visc_init, the rescaling factor used to set CS%Hbbl was changed from GV%Z_to_H to (US%Z_to_m*GV%m_to_H) so that it does not depend directly on RHO_0. These changes are extensive but localized to this file, with one new element of the opaque set_visc_CS type and 6 elements with altered units, 37 new or renamed internal variables, and 29 existing internal variables that have revised units. In particular one extensively used thickness curvature variable that had been called just "a" was renamed "crv" to more accurately reflect its purpose and to make it easier to find when rescaling it, with similar changes to two other closely related variables. These changes include the elimination of 29 rescaling factors between thickness and height units, as were two spots that inappropriately (and unnecessarily, as it turns out) used GV%Rho0 even when in non-Boussinesq mode. There are also 4 new debugging checksum output calls. In Boussinesq or semiBoussinesq mode, no public interfaces are changed and all answers are bitwise identical, but in non-Boussinesq mode answers will change and there are changes to the units of 3 variables in restart files. --- .../vertical/MOM_set_viscosity.F90 | 731 ++++++++++++------ 1 file changed, 474 insertions(+), 257 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 9ab300560b..9a99bc6b26 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -6,30 +6,30 @@ module MOM_set_visc use MOM_ALE, only : ALE_CS, ALE_remap_velocities, ALE_remap_interface_vals, ALE_remap_vertex_vals use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_cvmix_conv, only : cvmix_conv_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_cvmix_shear, only : cvmix_shear_is_used use MOM_debugging, only : uvchksum, hchksum use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, CORNER +use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_specific_vol_derivs use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing, mech_forcing, find_ustar use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : slasher, MOM_read_data use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex -use MOM_cvmix_shear, only : cvmix_shear_is_used -use MOM_cvmix_conv, only : cvmix_conv_is_used -use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE, OBC_DIRECTION_E +use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_restart, only : register_restart_field_as_obsolete use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E -use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S -use MOM_open_boundary, only : OBC_segment_type implicit none ; private @@ -48,6 +48,8 @@ module MOM_set_visc logical :: initialized = .false. !< True if this control structure has been initialized. real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. !! Runtime parameter `HBBL`. + real :: dz_bbl !< The static bottom boundary layer thickness in height units [Z ~> m]. + !! Runtime parameter `HBBL`. real :: cdrag !< The quadratic drag coefficient [nondim]. !! Runtime parameter `CDRAG`. real :: c_Smag !< The Laplacian Smagorinsky coefficient for @@ -55,14 +57,14 @@ module MOM_set_visc real :: drag_bg_vel !< An assumed unresolved background velocity for !! calculating the bottom drag [L T-1 ~> m s-1]. !! Runtime parameter `DRAG_BG_VEL`. - real :: BBL_thick_min !< The minimum bottom boundary layer thickness [H ~> m or kg m-2]. + real :: BBL_thick_min !< The minimum bottom boundary layer thickness [Z ~> m]. !! This might be Kv / (cdrag * drag_bg_vel) to give !! Kv as the minimum near-bottom viscosity. real :: Htbl_shelf !< A nominal thickness of the surface boundary layer for use !! in calculating the near-surface velocity [H ~> m or kg m-2]. - real :: Htbl_shelf_min !< The minimum surface boundary layer thickness [H ~> m or kg m-2]. - real :: KV_BBL_min !< The minimum viscosity in the bottom boundary layer [Z2 T-1 ~> m2 s-1]. - real :: KV_TBL_min !< The minimum viscosity in the top boundary layer [Z2 T-1 ~> m2 s-1]. + real :: Htbl_shelf_min !< The minimum surface boundary layer thickness [Z ~> m]. + real :: KV_BBL_min !< The minimum viscosity in the bottom boundary layer [H Z T-1 ~> m2 s-1 or Pa s] + real :: KV_TBL_min !< The minimum viscosity in the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] logical :: bottomdraglaw !< If true, the bottom stress is calculated with a !! drag law c_drag*|u|*u. The velocity magnitude !! may be an assumed value or it may be based on the @@ -80,7 +82,7 @@ module MOM_set_visc !! according to what fraction of the bottom they overlie. real :: Chan_drag_max_vol !< The maximum bottom boundary layer volume within which the !! channel drag is applied, normalized by the full cell area, - !! or a negative value to apply no maximum [H ~> m or kg m-2]. + !! or a negative value to apply no maximum [Z ~> m]. logical :: correct_BBL_bounds !< If true, uses the correct bounds on the BBL thickness and !! viscosity so that the bottom layer feels the intended drag. logical :: RiNo_mix !< If true, use Richardson number dependent mixing. @@ -90,8 +92,8 @@ module MOM_set_visc !! thickness of the viscous mixed layer [nondim] real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: ustar_min !< A minimum value of ustar to avoid numerical - !! problems [Z T-1 ~> m s-1]. If the value is small enough, - !! this should not affect the solution. + !! problems [H T-1 ~> m s-1 or kg m-2 s-1]. If the value is + !! small enough, this should not affect the solution. real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE !! decay scale [nondim] real :: omega_frac !< When setting the decay scale for turbulence, use this @@ -145,7 +147,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! Local variables real, dimension(SZIB_(G)) :: & - ustar, & ! The bottom friction velocity [Z T-1 ~> m s-1]. + ustar, & ! The bottom friction velocity [H T-1 ~> m s-1 or kg m-2 s-1]. T_EOS, & ! The temperature used to calculate the partial derivatives ! of density with T and S [C ~> degC]. S_EOS, & ! The salinity used to calculate the partial derivatives @@ -156,9 +158,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! layer with salinity [R S-1 ~> kg m-3 ppt-1]. press, & ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. umag_avg, & ! The average magnitude of velocities in the bottom boundary layer [L T-1 ~> m s-1]. - h_bbl_drag ! The thickness over which to apply drag as a body force [H ~> m or kg m-2]. + h_bbl_drag, & ! The thickness over which to apply drag as a body force [H ~> m or kg m-2]. + dz_bbl_drag ! The vertical height over which to apply drag as a body force [Z ~> m]. real :: htot ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: dztot ! Distance from the bottom up to some point [Z ~> m]. real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: dztot_vel ! Distance from the bottom up to some point [Z ~> m]. real :: Rhtot ! Running sum of thicknesses times the layer potential ! densities [H R ~> kg m-2 or kg2 m-5]. @@ -176,31 +181,49 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! direction [H ~> m or kg m-2]. h_vel, & ! Arithmetic mean of the layer thicknesses adjacent to a ! velocity point [H ~> m or kg m-2]. + dz_at_vel, & ! Vertical extent of a layer, using an upwind-biased + ! second order accurate estimate based on the previous velocity + ! direction [Z ~> m]. + dz_vel, & ! Arithmetic mean of the difference in across the layers adjacent + ! to a velocity point [Z ~> m]. T_vel, & ! Arithmetic mean of the layer temperatures adjacent to a ! velocity point [C ~> degC]. S_vel, & ! Arithmetic mean of the layer salinities adjacent to a ! velocity point [S ~> ppt]. + SpV_vel, & ! Arithmetic mean of the layer averaged specific volumes adjacent to a + ! velocity point [R-1 ~> kg m-3]. Rml_vel ! Arithmetic mean of the layer coordinate densities adjacent ! to a velocity point [R ~> kg m-3]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: h_vel_pos ! The arithmetic mean thickness at a velocity point ! plus H_neglect to avoid 0 values [H ~> m or kg m-2]. real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. - real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion - ! factor from lateral lengths to vertical depths [Z L-1 ~> nondim]. real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. + real :: cdrag_sqrt_H ! Square root of the drag coefficient, times a unit conversion factor + ! from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3]. + real :: cdrag_sqrt_H_RL ! Square root of the drag coefficient, times a unit conversion factor from + ! density times lateral lengths to layer thicknesses [H L-1 R-1 ~> m3 kg-1 or nondim] + real :: cdrag_L_to_H ! The drag coeffient times conversion factors from lateral + ! distance to thickness units [H L-1 ~> nondim or kg m-3] + real :: cdrag_RL_to_H ! The drag coeffient times conversion factors from density times lateral + ! distance to thickness units [H L-1 R-1 ~> m3 kg-1 or nondim] + real :: cdrag_conv ! The drag coeffient times a combination of static conversion factors and in + ! situ density or Boussinesq reference density [H L-1 ~> nondim or kg m-3] real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining ! the layer [H R ~> kg m-2 or kg2 m-5]. + real :: frac_used ! The fraction of the present layer that contributes to Dh and Ddz [nondim] real :: Dh ! The increment in layer thickness from ! the present layer [H ~> m or kg m-2]. - real :: bbl_thick ! The thickness of the bottom boundary layer [H ~> m or kg m-2]. - real :: bbl_thick_Z ! The thickness of the bottom boundary layer [Z ~> m]. - real :: kv_bbl ! The bottom boundary layer viscosity [Z2 T-1 ~> m2 s-1]. + real :: Ddz ! The increment in height change from the present layer [Z ~> m]. + real :: bbl_thick ! The thickness of the bottom boundary layer [Z ~> m]. + real :: BBL_thick_max ! A huge upper bound on the boundary layer thickness [Z ~> m]. + real :: kv_bbl ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s] real :: C2f ! C2f = 2*f at velocity points [T-1 ~> s-1]. real :: U_bg_sq ! The square of an assumed background @@ -210,69 +233,75 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: hwtot ! Sum of the thicknesses used to calculate ! the near-bottom velocity magnitude [H ~> m or kg m-2]. real :: I_hwtot ! The Adcroft reciprocal of hwtot [H-1 ~> m-1 or m2 kg-1]. + real :: dzwtot ! The vertical extent of the region used to calculate + ! the near-bottom velocity magnitude [Z ~> m]. real :: hutot ! Running sum of thicknesses times the velocity ! magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real :: Thtot ! Running sum of thickness times temperature [C H ~> degC m or degC kg m-2]. real :: Shtot ! Running sum of thickness times salinity [S H ~> ppt m or ppt kg m-2]. + real :: SpV_htot ! Running sum of thickness times specific volume [R-1 H ~> m4 kg-1 or m] real :: hweight ! The thickness of a layer that is within Hbbl ! of the bottom [H ~> m or kg m-2]. + real :: dzweight ! The counterpart of hweight in height units [Z ~> m]. real :: v_at_u, u_at_v ! v at a u point or vice versa [L T-1 ~> m s-1]. real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors - ! [R T2 H Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! [R T2 H-1 ~> kg s2 m-4 or s2 m-1]. ! The 400 is a constant proposed by Killworth and Edwards, 1999. real, dimension(SZI_(G),SZJ_(G),max(GV%nk_rho_varies,1)) :: & Rml ! The mixed layer coordinate density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually set to 2e7 Pa = 2000 dbar). - real :: D_vel ! The bottom depth at a velocity point [H ~> m or kg m-2]. - real :: Dp, Dm ! The depths at the edges of a velocity cell [H ~> m or kg m-2]. - real :: a ! a is the curvature of the bottom depth across a - ! cell, times the cell width squared [H ~> m or kg m-2]. - real :: a_3, a_12 ! a/3 and a/12 [H ~> m or kg m-2]. - real :: C24_a ! 24/a [H-1 ~> m-1 or m2 kg-1]. + real :: D_vel ! The bottom depth at a velocity point [Z ~> m]. + real :: Dp, Dm ! The depths at the edges of a velocity cell [Z ~> m]. + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: C24_crv ! 24/crv [Z-1 ~> m-1]. real :: slope ! The absolute value of the bottom depth slope across - ! a cell times the cell width [H ~> m or kg m-2]. - real :: apb_4a, ax2_3apb ! Various nondimensional ratios of a and slope [nondim]. - real :: a2x48_apb3, Iapb, Ibma_2 ! Combinations of a and slope [H-1 ~> m-1 or m2 kg-1]. - ! All of the following "volumes" have units of thickness because they are normalized + ! a cell times the cell width [Z ~> m]. + real :: apb_4a, ax2_3apb ! Various nondimensional ratios of crv and slope [nondim]. + real :: a2x48_apb3, Iapb, Ibma_2 ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] + ! All of the following "volumes" have units of vertical heights because they are normalized ! by the full horizontal area of a velocity cell. real :: Vol_bbl_chan ! The volume of the bottom boundary layer as used in the channel ! drag parameterization, normalized by the full horizontal area - ! of the velocity cell [H ~> m or kg m-2]. - real :: Vol_open ! The cell volume above which it is open [H ~> m or kg m-2]. - real :: Vol_direct ! With less than Vol_direct [H ~> m or kg m-2], there is a direct + ! of the velocity cell [Z ~> m]. + real :: Vol_open ! The cell volume above which it is open [Z ~> m]. + real :: Vol_direct ! With less than Vol_direct [Z ~> m], there is a direct ! solution of a cubic equation for L. real :: Vol_2_reg ! The cell volume above which there are two separate - ! open areas that must be integrated [H ~> m or kg m-2]. + ! open areas that must be integrated [Z ~> m]. real :: vol ! The volume below the interface whose normalized - ! width is being sought [H ~> m or kg m-2]. + ! width is being sought [Z ~> m]. real :: vol_below ! The volume below the interface below the one that - ! is currently under consideration [H ~> m or kg m-2]. + ! is currently under consideration [Z ~> m]. real :: Vol_err ! The error in the volume with the latest estimate of - ! L, or the error for the interface below [H ~> m or kg m-2]. - real :: Vol_quit ! The volume error below which to quit iterating [H ~> m or kg m-2]. - real :: Vol_tol ! A volume error tolerance [H ~> m or kg m-2]. + ! L, or the error for the interface below [Z ~> m]. + real :: Vol_quit ! The volume error below which to quit iterating [Z ~> m]. + real :: Vol_tol ! A volume error tolerance [Z ~> m]. real :: L(SZK_(GV)+1) ! The fraction of the full cell width that is open at ! the depth of each interface [nondim]. real :: L_direct ! The value of L above volume Vol_direct [nondim]. - real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. - real :: Vol_err_max ! The volume error for the upper bound on the correct value for L [H ~> m or kg m-2] - real :: Vol_err_min ! The volume error for the lower bound on the correct value for L [H ~> m or kg m-2] - real :: Vol_0 ! A deeper volume with known width L0 [H ~> m or kg m-2]. + real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. + real :: Vol_err_max ! The volume error for the upper bound on the correct value for L [Z ~> m] + real :: Vol_err_min ! The volume error for the lower bound on the correct value for L [Z ~> m] + real :: Vol_0 ! A deeper volume with known width L0 [Z ~> m]. real :: L0 ! The value of L above volume Vol_0 [nondim]. - real :: dVol ! vol - Vol_0 [H ~> m or kg m-2]. + real :: dVol ! vol - Vol_0 [Z ~> m]. real :: dV_dL2 ! The partial derivative of volume with L squared - ! evaluated at L=L0 [H ~> m or kg m-2]. + ! evaluated at L=L0 [Z ~> m]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: ustH ! ustar converted to units of H T-1 [H T-1 ~> m s-1 or kg m-2 s-1]. real :: root ! A temporary variable [H T-1 ~> m s-1 or kg m-2 s-1]. real :: Cell_width ! The transverse width of the velocity cell [L ~> m]. - real :: Rayleigh ! A nondimensional value that is multiplied by the layer's - ! velocity magnitude to give the Rayleigh drag velocity, times - ! a lateral to vertical distance conversion factor [Z L-1 ~> nondim]. + real :: Rayleigh ! A factor that is multiplied by the layer's velocity magnitude + ! to give the Rayleigh drag velocity, times a lateral distance to + ! thickness conversion factor [H L-1 ~> nondim or kg m-3]. real :: gam ! The ratio of the change in the open interface width ! to the open interface width atop a cell [nondim]. real :: BBL_frac ! The fraction of a layer's drag that goes into the @@ -287,7 +316,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: tmp ! A temporary variable, sometimes in [Z ~> m] real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] real :: curv_tol ! Numerator of curvature cubed, used to estimate - ! accuracy of a single L(:) Newton iteration [H5 ~> m5 or kg5 m-10] + ! accuracy of a single L(:) Newton iteration [Z5 ~> m5] logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration logical :: use_BBL_EOS, do_i(SZIB_(G)) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state @@ -299,8 +328,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Isq = G%isc-1 ; Ieq = G%IecB ; Jsq = G%jsc-1 ; Jeq = G%JecB nkmb = GV%nk_rho_varies ; nkml = GV%nkml h_neglect = GV%H_subroundoff - Rho0x400_G = 400.0*(GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H - Vol_quit = 0.9*GV%Angstrom_H + h_neglect + dz_neglect = GV%dZ_subroundoff + + Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) + Vol_quit = (0.9*GV%Angstrom_Z + dz_neglect) C2pi_3 = 8.0*atan(1.0)/3.0 if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(BBL): "//& @@ -313,6 +344,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) call hchksum(h,"Start set_viscous_BBL h", G%HI, haloshift=1, scale=GV%H_to_m) if (associated(tv%T)) call hchksum(tv%T, "Start set_viscous_BBL T", G%HI, haloshift=1, scale=US%C_to_degC) if (associated(tv%S)) call hchksum(tv%S, "Start set_viscous_BBL S", G%HI, haloshift=1, scale=US%S_to_ppt) + if (allocated(tv%SpV_avg)) & + call hchksum(tv%SpV_avg, "Start set_viscous_BBL SpV_avg", G%HI, haloshift=1, scale=US%kg_m3_to_R) + if (allocated(tv%SpV_avg)) call hchksum(tv%SpV_avg, "Cornerless SpV_avg", G%HI, & + haloshift=1, omit_corners=.true., scale=US%kg_m3_to_R) + if (associated(tv%T)) call hchksum(tv%T, "Cornerless T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Cornerless S", G%HI, haloshift=1, omit_corners=.true., scale=US%S_to_ppt) endif use_BBL_EOS = associated(tv%eqn_of_state) .and. CS%BBL_use_EOS @@ -320,11 +357,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel cdrag_sqrt = sqrt(CS%cdrag) - cdrag_sqrt_Z = US%L_to_Z * sqrt(CS%cdrag) + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H + cdrag_L_to_H = CS%cdrag * US%L_to_m * GV%m_to_H + cdrag_RL_to_H = CS%cdrag * US%L_to_Z * GV%RZ_to_H + BBL_thick_max = G%Rad_Earth_L * US%L_to_Z K2 = max(nkmb+1, 2) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + ! With a linear drag law, the friction velocity is already known. -! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_H*CS%drag_bg_vel if ((nkml>0) .and. .not.use_BBL_EOS) then EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) @@ -393,10 +437,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (allocated(visc%Ray_u)) visc%Ray_u(:,:,:) = 0.0 if (allocated(visc%Ray_v)) visc%Ray_v(:,:,:) = 0.0 - !$OMP parallel do default(private) shared(u,v,h,tv,visc,G,GV,US,CS,Rml,nz,nkmb, & - !$OMP nkml,Isq,Ieq,Jsq,Jeq,h_neglect,Rho0x400_G,C2pi_3, & - !$OMP U_bg_sq,cdrag_sqrt_Z,cdrag_sqrt,K2,use_BBL_EOS, & - !$OMP OBC,maxitt,D_u,D_v,mask_u,mask_v, pbv) & + !$OMP parallel do default(private) shared(u,v,h,dz,tv,visc,G,GV,US,CS,Rml,nz,nkmb,nkml,K2, & + !$OMP Isq,Ieq,Jsq,Jeq,h_neglect,dz_neglect,Rho0x400_G,C2pi_3, & + !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL, & + !$OMP cdrag_L_to_H,cdrag_RL_to_H,use_BBL_EOS,BBL_thick_max, & + !$OMP OBC,maxitt,D_u,D_v,mask_u,mask_v,pbv) & !$OMP firstprivate(Vol_quit) do j=Jsq,Jeq ; do m=1,2 @@ -420,16 +465,20 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then ! u-points do k=1,nz ; do I=is,ie if (do_i(I)) then - if (u(I,j,k) *(h(i+1,j,k) - h(i,j,k)) >= 0) then + if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then ! If the flow is from thin to thick then bias towards the thinner thickness h_at_vel(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / & (h(i,j,k) + h(i+1,j,k) + h_neglect) + dz_at_vel(I,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / & + (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) else ! If the flow is from thick to thin then use the simple average thickness h_at_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_at_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) endif endif h_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) enddo ; enddo if (use_BBL_EOS) then ; do k=1,nz ; do I=is,ie ! Perhaps these should be thickness weighted. @@ -438,6 +487,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) enddo ; enddo ; else ; do k=1,nkmb ; do I=is,ie Rml_vel(I,k) = 0.5 * (Rml(i,j,k) + Rml(i+1,j,k)) enddo ; enddo ; endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do I=is,ie + SpV_vel(I,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + enddo ; enddo ; endif else ! v-points do k=1,nz ; do i=is,ie if (do_i(i)) then @@ -445,19 +497,27 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! If the flow is from thin to thick then bias towards the thinner thickness h_at_vel(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / & (h(i,j,k) + h(i,j+1,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / & + (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) else ! If the flow is from thick to thin then use the simple average thickness h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) endif endif h_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) enddo ; enddo if (use_BBL_EOS) then ; do k=1,nz ; do i=is,ie + ! Perhaps these should be thickness weighted. T_vel(i,k) = 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) S_vel(i,k) = 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k)) enddo ; enddo ; else ; do k=1,nkmb ; do i=is,ie Rml_vel(i,k) = 0.5 * (Rml(i,j,k) + Rml(i,j+1,k)) enddo ; enddo ; endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do i=is,ie + SpV_vel(i,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + enddo ; enddo ; endif endif if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then @@ -467,6 +527,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then do k=1,nz h_at_vel(I,k) = h(i,j,k) ; h_vel(I,k) = h(i,j,k) + dz_at_vel(I,k) = dz(i,j,k) ; dz_vel(I,k) = dz(i,j,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -477,9 +538,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(I,k) = Rml(i,j,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(I,k) = tv%SpV_avg(i,j,k) + enddo ; endif elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then do k=1,nz h_at_vel(I,k) = h(i+1,j,k) ; h_vel(I,k) = h(i+1,j,k) + dz_at_vel(I,k) = dz(i+1,j,k) ; dz_vel(I,k) = dz(i+1,j,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -490,6 +555,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(I,k) = Rml(i+1,j,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(I,k) = tv%SpV_avg(i+1,j,k) + enddo ; endif endif endif ; enddo else @@ -497,6 +565,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then do k=1,nz h_at_vel(i,k) = h(i,j,k) ; h_vel(i,k) = h(i,j,k) + dz_at_vel(i,k) = dz(i,j,k) ; dz_vel(i,k) = dz(i,j,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -507,9 +576,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(i,k) = Rml(i,j,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(i,k) = tv%SpV_avg(i,j,k) + enddo ; endif elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then do k=1,nz h_at_vel(i,k) = h(i,j+1,k) ; h_vel(i,k) = h(i,j+1,k) + dz_at_vel(i,k) = dz(i,j+1,k) ; dz_vel(i,k) = dz(i,j+1,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -520,6 +593,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(i,k) = Rml(i,j+1,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(i,k) = tv%SpV_avg(i,j+1,k) + enddo ; endif endif endif ; enddo endif @@ -531,16 +607,20 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! Used in ustar(i) do i=is,ie ; if (do_i(i)) then htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 - Thtot = 0.0 ; Shtot = 0.0 + dztot_vel = 0.0 ; dzwtot = 0.0 + Thtot = 0.0 ; Shtot = 0.0 ; SpV_htot = 0.0 do k=nz,1,-1 if (htot_vel>=CS%Hbbl) exit ! terminate the k loop hweight = MIN(CS%Hbbl - htot_vel, h_at_vel(i,k)) if (hweight < 1.5*GV%Angstrom_H + h_neglect) cycle + dzweight = MIN(CS%dz_bbl - dztot_vel, dz_at_vel(i,k)) - htot_vel = htot_vel + h_at_vel(i,k) + htot_vel = htot_vel + h_at_vel(i,k) hwtot = hwtot + hweight + dztot_vel = dztot_vel + dz_at_vel(i,k) + dzwtot = dzwtot + dzweight if ((.not.CS%linear_drag) .and. (hweight >= 0.0)) then ; if (m==1) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) @@ -562,20 +642,28 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Thtot = Thtot + hweight * T_vel(i,k) Shtot = Shtot + hweight * S_vel(i,k) endif + if (allocated(tv%SpV_avg) .and. (hweight >= 0.0)) then + SpV_htot = SpV_htot + hweight * SpV_vel(i,k) + endif enddo ! end of k loop - ! Set u* based on u*^2 = Cdrag u_bbl^2 - if (.not.CS%linear_drag .and. (hwtot > 0.0)) then - ustar(i) = cdrag_sqrt_Z*hutot / hwtot - else - ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel - endif - ! Find the Adcroft reciprocal of the total thickness weights I_hwtot = 0.0 ; if (hwtot > 0.0) I_hwtot = 1.0 / hwtot + ! Set u* based on u*^2 = Cdrag u_bbl^2 + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(i) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(i) = cdrag_sqrt_H_RL * hutot / SpV_htot + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(i) = cdrag_sqrt_H * hutot / hwtot + endif + umag_avg(i) = hutot * I_hwtot h_bbl_drag(i) = hwtot + dz_bbl_drag(i) = dzwtot if (use_BBL_EOS) then ; if (hwtot > 0.0) then T_EOS(i) = Thtot/hwtot ; S_EOS(i) = Shtot/hwtot @@ -592,7 +680,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif ; enddo else - do i=is,ie ; ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel ; enddo + do i=is,ie ; ustar(i) = cdrag_sqrt_H*CS%drag_bg_vel ; enddo endif ! Not linear_drag if (use_BBL_EOS) then @@ -621,6 +709,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! The 400.0 in this expression is the square of a Ci introduced in KW99, eq. 2.22. ustarsq = Rho0x400_G * ustar(i)**2 ! Note not in units of u*^2 but [H R ~> kg m-2 or kg2 m-5] htot = 0.0 + dztot = 0.0 ! Calculate the thickness of a stratification limited BBL ignoring rotation: ! h_N = Ci u* / N (limit of KW99 eq. 2.20 for |f|->0) @@ -649,20 +738,26 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if ((oldfn + Dfn) <= ustarsq) then ! Use whole layer Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else ! Use only part of the layer - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif ! Increment total BBL thickness and cumulative T and S htot = htot + Dh + dztot = dztot + Ddz Thtot = Thtot + T_vel(i,k)*Dh ; Shtot = Shtot + S_vel(i,k)*Dh enddo if ((oldfn < ustarsq) .and. h_at_vel(i,1) > 0.0) then ! Layer 1 might be part of the BBL. if (dR_dT(i) * (Thtot - T_vel(i,1)*htot) + & - dR_dS(i) * (Shtot - S_vel(i,1)*htot) < ustarsq) & + dR_dS(i) * (Shtot - S_vel(i,1)*htot) < ustarsq) then htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif endif ! Examination of layer 1. else ! Use Rlay and/or the coordinate density as density variables. Rhtot = 0.0 @@ -674,11 +769,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) cycle elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot = htot + Dh + dztot = dztot + Ddz Rhtot = Rhtot + GV%Rlay(k)*Dh enddo if (nkml>0) then @@ -690,16 +789,26 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) cycle elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot = htot + Dh + dztot = dztot + Ddz Rhtot = Rhtot + Rml_vel(i,k)*Dh enddo - if (Rhtot - Rml_vel(i,1)*htot < ustarsq) htot = htot + h_at_vel(i,1) + if (Rhtot - Rml_vel(i,1)*htot < ustarsq) then + htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif else - if (Rhtot - GV%Rlay(1)*htot < ustarsq) htot = htot + h_at_vel(i,1) + if (Rhtot - GV%Rlay(1)*htot < ustarsq) then + htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif endif endif ! use_BBL_EOS @@ -721,21 +830,20 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (CS%cdrag * U_bg_sq <= 0.0) then ! This avoids NaNs and overflows, and could be used in all cases, ! but is not bitwise identical to the current code. - ustH = ustar(i)*GV%Z_to_H ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) - if (htot*ustH <= (CS%BBL_thick_min+h_neglect) * (0.5*ustH + root)) then + ustH = ustar(i) ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) + if (dztot*ustH <= (CS%BBL_thick_min+dz_neglect) * (0.5*ustH + root)) then bbl_thick = CS%BBL_thick_min else ! The following expression reads ! h_bbl = h_N u* / ( 1/2 u* + sqrt( 1/4 u*^2 + ( 2 f h_N )^2 ) ) ! which is h_bbl = h_N u*/(xp u*) as described above. - bbl_thick = (htot * ustH) / (0.5*ustH + root) + bbl_thick = (dztot * ustH) / (0.5*ustH + root) endif else ! The following expression reads ! h_bbl = h_N / ( 1/2 + sqrt( 1/4 + ( 2 f h_N / u* )^2 ) ) ! which is h_bbl = h_N/xp as described above. - bbl_thick = htot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f/ & - ((ustar(i)*ustar(i)) * (GV%Z_to_H**2)) ) ) + bbl_thick = dztot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f / (ustar(i)*ustar(i)) ) ) if (bbl_thick < CS%BBL_thick_min) bbl_thick = CS%BBL_thick_min endif @@ -748,12 +856,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! need to set that scale here. In fact, viscously reducing the ! shears over an excessively large region reduces the efficacy of ! the Richardson number dependent mixing. - ! In other words, if using RiNo_mix then CS%Hbbl acts as an upper bound on + ! In other words, if using RiNo_mix then CS%dz_bbl acts as an upper bound on ! bbl_thick. - if ((bbl_thick > 0.5*CS%Hbbl) .and. (CS%RiNo_mix)) bbl_thick = 0.5*CS%Hbbl + if ((bbl_thick > 0.5*CS%dz_bbl) .and. (CS%RiNo_mix)) bbl_thick = 0.5*CS%dz_bbl ! If drag is a body force, bbl_thick is HBBL - if (CS%body_force_drag) bbl_thick = h_bbl_drag(i) + if (CS%body_force_drag) bbl_thick = dz_bbl_drag(i) if (CS%Channel_drag) then ! The drag within the bottommost Vol_bbl_chan is applied as a part of @@ -779,45 +887,42 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif if (Dm > Dp) then ; tmp = Dp ; Dp = Dm ; Dm = tmp ; endif - ! Convert the D's to the units of thickness. - Dp = GV%Z_to_H*Dp ; Dm = GV%Z_to_H*Dm ; D_vel = GV%Z_to_H*D_vel - - a_3 = (Dp + Dm - 2.0*D_vel) ; a = 3.0*a_3 ; a_12 = 0.25*a_3 + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 slope = Dp - Dm ! If the curvature is small enough, there is no reason not to assume ! a uniformly sloping or flat bottom. - if (abs(a) < 1e-2*(slope + CS%BBL_thick_min)) a = 0.0 + if (abs(crv) < 1e-2*(slope + CS%BBL_thick_min)) crv = 0.0 ! Each cell extends from x=-1/2 to 1/2, and has a topography - ! given by D(x) = a*x^2 + b*x + D - a/12. + ! given by D(x) = crv*x^2 + slope*x + D - crv/12. ! Calculate the volume above which the entire cell is open and the ! other volumes at which the equation that is solved for L changes. - if (a > 0.0) then - if (slope >= a) then + if (crv > 0.0) then + if (slope >= crv) then Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open else - tmp = slope/a - Vol_open = 0.25*slope*tmp + C1_12*a - Vol_2_reg = 0.5*tmp**2 * (a - C1_3*slope) + tmp = slope/crv + Vol_open = 0.25*slope*tmp + C1_12*crv + Vol_2_reg = 0.5*tmp**2 * (crv - C1_3*slope) endif - ! Define some combinations of a & b for later use. - C24_a = 24.0/a ; Iapb = 1.0/(a+slope) - apb_4a = (slope+a)/(4.0*a) ; a2x48_apb3 = (48.0*(a*a))*(Iapb**3) - ax2_3apb = 2.0*C1_3*a*Iapb - elseif (a == 0.0) then + ! Define some combinations of crv & slope for later use. + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + apb_4a = (slope+crv)/(4.0*crv) ; a2x48_apb3 = (48.0*(crv*crv))*(Iapb**3) + ax2_3apb = 2.0*C1_3*crv*Iapb + elseif (crv == 0.0) then Vol_open = 0.5*slope if (slope > 0) Iapb = 1.0/slope - else ! a < 0.0 + else ! crv < 0.0 Vol_open = D_vel - Dm - if (slope >= -a) then - Iapb = 1.0e30 ; if (slope+a /= 0.0) Iapb = 1.0/(a+slope) - Vol_direct = 0.0 ; L_direct = 0.0 ; C24_a = 0.0 + if (slope >= -crv) then + Iapb = 1.0e30*US%Z_to_m ; if (slope+crv /= 0.0) Iapb = 1.0/(crv+slope) + Vol_direct = 0.0 ; L_direct = 0.0 ; C24_crv = 0.0 else - C24_a = 24.0/a ; Iapb = 1.0/(a+slope) - L_direct = 1.0 + slope/a ! L_direct < 1 because a < 0 - Vol_direct = -C1_6*a*L_direct**3 + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + L_direct = 1.0 + slope/crv ! L_direct < 1 because crv < 0 + Vol_direct = -C1_6*crv*L_direct**3 endif - Ibma_2 = 2.0 / (slope - a) + Ibma_2 = 2.0 / (slope - crv) endif L(nz+1) = 0.0 ; vol = 0.0 ; Vol_err = 0.0 ; BBL_visc_frac = 0.0 @@ -825,18 +930,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) do K=nz,1,-1 vol_below = vol - vol = vol + h_vel(i,k) + vol = vol + dz_vel(i,k) h_vel_pos = h_vel(i,k) + h_neglect if (vol >= Vol_open) then ; L(K) = 1.0 - elseif (a == 0) then ! The bottom has no curvature. + elseif (crv == 0) then ! The bottom has no curvature. L(K) = sqrt(2.0*vol*Iapb) - elseif (a > 0) then + elseif (crv > 0) then ! There may be a minimum depth, and there are ! analytic expressions for L for all cases. if (vol < Vol_2_reg) then ! In this case, there is a contiguous open region and - ! vol = 0.5*L^2*(slope + a/3*(3-4L)). + ! vol = 0.5*L^2*(slope + crv/3*(3-4L)). if (a2x48_apb3*vol < 1e-8) then ! Could be 1e-7? ! There is a very good approximation here for massless layers. L0 = sqrt(2.0*vol*Iapb) ; L(K) = L0*(1.0 + ax2_3apb*L0) @@ -845,67 +950,67 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) 2.0 * cos(C1_3*acos(a2x48_apb3*vol - 1.0) - C2pi_3)) endif ! To check the answers. - ! Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol + ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol else ! There are two separate open regions. - ! vol = slope^2/4a + a/12 - (a/12)*(1-L)^2*(1+2L) - ! At the deepest volume, L = slope/a, at the top L = 1. - !L(K) = 0.5 - cos(C1_3*acos(1.0 - C24_a*(Vol_open - vol)) - C2pi_3) - tmp_val_m1_to_p1 = 1.0 - C24_a*(Vol_open - vol) + ! vol = slope^2/4crv + crv/12 - (crv/12)*(1-L)^2*(1+2L) + ! At the deepest volume, L = slope/crv, at the top L = 1. + !L(K) = 0.5 - cos(C1_3*acos(1.0 - C24_crv*(Vol_open - vol)) - C2pi_3) + tmp_val_m1_to_p1 = 1.0 - C24_crv*(Vol_open - vol) tmp_val_m1_to_p1 = max(-1., min(1., tmp_val_m1_to_p1)) L(K) = 0.5 - cos(C1_3*acos(tmp_val_m1_to_p1) - C2pi_3) ! To check the answers. - ! Vol_err = Vol_open - a_12*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol + ! Vol_err = Vol_open - 0.25*crv_3*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol endif else ! a < 0. if (vol <= Vol_direct) then ! Both edges of the cell are bounded by walls. - L(K) = (-0.25*C24_a*vol)**C1_3 + L(K) = (-0.25*C24_crv*vol)**C1_3 else ! x_R is at 1/2 but x_L is in the interior & L is found by solving - ! vol = 0.5*L^2*(slope + a/3*(3-4L)) + ! vol = 0.5*L^2*(slope + crv/3*(3-4L)) - ! Vol_err = 0.5*(L(K+1)*L(K+1))*(slope + a_3*(3.0-4.0*L(K+1))) - vol_below + ! Vol_err = 0.5*(L(K+1)*L(K+1))*(slope + crv_3*(3.0-4.0*L(K+1))) - vol_below ! Change to ... - ! if (min(Vol_below + Vol_err, vol) <= Vol_direct) then ? + ! if (min(vol_below + Vol_err, vol) <= Vol_direct) then ? if (vol_below + Vol_err <= Vol_direct) then L0 = L_direct ; Vol_0 = Vol_direct else - L0 = L(K+1) ; Vol_0 = Vol_below + Vol_err - ! Change to Vol_0 = min(Vol_below + Vol_err, vol) ? + L0 = L(K+1) ; Vol_0 = vol_below + Vol_err + ! Change to Vol_0 = min(vol_below + Vol_err, vol) ? endif ! Try a relatively simple solution that usually works well ! for massless layers. - dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = (vol-Vol_0) - ! dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = max(vol-Vol_0, 0.0) + dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = (vol-Vol_0) + ! dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = max(vol-Vol_0, 0.0) use_L0 = .false. do_one_L_iter = .false. if (CS%answer_date < 20190101) then - curv_tol = GV%Angstrom_H*dV_dL2**2 & - * (0.25 * dV_dL2 * GV%Angstrom_H - a * L0 * dVol) - do_one_L_iter = (a * a * dVol**3) < curv_tol + curv_tol = GV%Angstrom_Z*dV_dL2**2 & + * (0.25 * dV_dL2 * GV%Angstrom_Z - crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol else ! The following code is more robust when GV%Angstrom_H=0, but ! it changes answers. use_L0 = (dVol <= 0.) - Vol_tol = max(0.5 * GV%Angstrom_H + GV%H_subroundoff, 1e-14 * vol) - Vol_quit = max(0.9 * GV%Angstrom_H + GV%H_subroundoff, 1e-14 * vol) + Vol_tol = max(0.5 * GV%Angstrom_Z + dz_neglect, 1e-14 * vol) + Vol_quit = max(0.9 * GV%Angstrom_Z + dz_neglect, 1e-14 * vol) curv_tol = Vol_tol * dV_dL2**2 & - * (dV_dL2 * Vol_tol - 2.0 * a * L0 * dVol) - do_one_L_iter = (a * a * dVol**3) < curv_tol + * (dV_dL2 * Vol_tol - 2.0 * crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol endif if (use_L0) then L(K) = L0 - Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol elseif (do_one_L_iter) then ! One iteration of Newton's method should give an estimate ! that is accurate to within Vol_tol. L(K) = sqrt(L0*L0 + dVol / dV_dL2) - Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol else if (dV_dL2*(1.0-L0*L0) < dVol + & dV_dL2 * (Vol_open - Vol)*Ibma_2) then @@ -913,10 +1018,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) else L_max = sqrt(L0*L0 + dVol / dV_dL2) endif - L_min = sqrt(L0*L0 + dVol / (0.5*(slope+a) - a*L_max)) + L_min = sqrt(L0*L0 + dVol / (0.5*(slope+crv) - crv*L_max)) - Vol_err_min = 0.5*(L_min**2)*(slope + a_3*(3.0-4.0*L_min)) - vol - Vol_err_max = 0.5*(L_max**2)*(slope + a_3*(3.0-4.0*L_max)) - vol + Vol_err_min = 0.5*(L_min**2)*(slope + crv_3*(3.0-4.0*L_min)) - vol + Vol_err_max = 0.5*(L_max**2)*(slope + crv_3*(3.0-4.0*L_max)) - vol ! if ((abs(Vol_err_min) <= Vol_quit) .or. (Vol_err_min >= Vol_err_max)) then if (abs(Vol_err_min) <= Vol_quit) then L(K) = L_min ; Vol_err = Vol_err_min @@ -924,13 +1029,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) L(K) = sqrt((L_min**2*Vol_err_max - L_max**2*Vol_err_min) / & (Vol_err_max - Vol_err_min)) do itt=1,maxitt - Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol if (abs(Vol_err) <= Vol_quit) exit ! Take a Newton's method iteration. This equation has proven ! robust enough not to need bracketing. - L(K) = L(K) - Vol_err / (L(K)* (slope + a - 2.0*a*L(K))) + L(K) = L(K) - Vol_err / (L(K)* (slope + crv - 2.0*crv*L(K))) ! This would be a Newton's method iteration for L^2: - ! L(K) = sqrt(L(K)*L(K) - Vol_err / (0.5*(slope+a) - a*L(K))) + ! L(K) = sqrt(L(K)*L(K) - Vol_err / (0.5*(slope+crv) - crv*L(K))) enddo endif ! end of iterative solver endif ! end of 1-boundary alternatives. @@ -951,12 +1056,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) BBL_frac = 0.0 endif + if (allocated(tv%SpV_avg)) then + cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k) + else + cdrag_conv = cdrag_L_to_H + endif + if (m==1) then ; Cell_width = G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k) else ; Cell_width = G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k) ; endif gam = 1.0 - L(K+1)/L(K) - Rayleigh = US%L_to_Z * CS%cdrag * (L(K)-L(K+1)) * (1.0-BBL_frac) * & + Rayleigh = cdrag_conv * (L(K)-L(K+1)) * (1.0-BBL_frac) * & (12.0*CS%c_Smag*h_vel_pos) / (12.0*CS%c_Smag*h_vel_pos + & - US%L_to_Z*GV%Z_to_H * CS%cdrag * gam*(1.0-gam)*(1.0-1.5*gam) * L(K)**2 * Cell_width) + cdrag_conv * gam*(1.0-gam)*(1.0-1.5*gam) * L(K)**2 * Cell_width) else ! This layer feels no drag. Rayleigh = 0.0 endif @@ -964,12 +1075,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then if (Rayleigh > 0.0) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - visc%Ray_u(I,j,k) = GV%Z_to_H*Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) + visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) else ; visc%Ray_u(I,j,k) = 0.0 ; endif else if (Rayleigh > 0.0) then u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) - visc%Ray_v(i,J,k) = GV%Z_to_H*Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) + visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) else ; visc%Ray_v(i,J,k) = 0.0 ; endif endif @@ -978,20 +1089,19 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! Set the near-bottom viscosity to a value which will give ! the correct stress when the shear occurs over bbl_thick. ! See next block for explanation. - bbl_thick_Z = bbl_thick * GV%H_to_Z if (CS%correct_BBL_bounds .and. & - cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac <= CS%Kv_BBL_min) then + cdrag_sqrt*ustar(i)*bbl_thick*BBL_visc_frac <= CS%Kv_BBL_min) then ! If the bottom stress implies less viscosity than Kv_BBL_min then ! set kv_bbl to the bound and recompute bbl_thick to be consistent ! but with a ridiculously large upper bound on thickness (for Cd u*=0) kv_bbl = CS%Kv_BBL_min - if (cdrag_sqrt*ustar(i)*BBL_visc_frac*G%Rad_Earth_L*US%L_to_Z > kv_bbl) then - bbl_thick_Z = kv_bbl / ( cdrag_sqrt*ustar(i)*BBL_visc_frac ) + if ((cdrag_sqrt*ustar(i))*BBL_visc_frac*BBL_thick_max > kv_bbl) then + bbl_thick = kv_bbl / ( (cdrag_sqrt*ustar(i)) * BBL_visc_frac ) else - bbl_thick_Z = G%Rad_Earth_L * US%L_to_Z + bbl_thick = BBL_thick_max endif else - kv_bbl = cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac + kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick*BBL_visc_frac endif else ! Not Channel_drag. @@ -1003,27 +1113,26 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! - u_bbl is embedded in u* since u*^2 = Cdrag u_bbl^2 ! - The average shear in the BBL is du/dz = 2 * u_bbl / h_bbl ! (which assumes a linear profile, hence the "2") - ! - bbl_thick was bounded to <= 0.5 * CS%Hbbl + ! - bbl_thick was bounded to <= 0.5 * CS%dz_bbl ! - The viscous stress kv_bbl du/dz should balance tau_b ! Cdrag u_bbl^2 = kv_bbl du/dz ! = 2 kv_bbl u_bbl ! so ! kv_bbl = 0.5 h_bbl Cdrag u_bbl ! = 0.5 h_bbl sqrt(Cdrag) u* - bbl_thick_Z = bbl_thick * GV%H_to_Z if (CS%correct_BBL_bounds .and. & - cdrag_sqrt*ustar(i)*bbl_thick_Z <= CS%Kv_BBL_min) then + cdrag_sqrt*ustar(i)*bbl_thick <= CS%Kv_BBL_min) then ! If the bottom stress implies less viscosity than Kv_BBL_min then ! set kv_bbl to the bound and recompute bbl_thick to be consistent ! but with a ridiculously large upper bound on thickness (for Cd u*=0) kv_bbl = CS%Kv_BBL_min - if (cdrag_sqrt*ustar(i)*G%Rad_Earth_L*US%L_to_Z > kv_bbl) then - bbl_thick_Z = kv_bbl / ( cdrag_sqrt*ustar(i) ) + if ((cdrag_sqrt*ustar(i))*BBL_thick_max > kv_bbl) then + bbl_thick = kv_bbl / ( cdrag_sqrt*ustar(i) ) else - bbl_thick_Z = G%Rad_Earth_L * US%L_to_Z + bbl_thick = BBL_thick_max endif else - kv_bbl = cdrag_sqrt*ustar(i)*bbl_thick_Z + kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick endif endif @@ -1033,10 +1142,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) I_hwtot = 1.0 / h_bbl_drag(i) do k=nz,1,-1 h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot + if (allocated(tv%SpV_avg)) then + cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k) + else + cdrag_conv = cdrag_L_to_H + endif if (m==1) then - visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + GV%Z_to_H*(CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr + visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (cdrag_conv * umag_avg(I)) * h_bbl_fr else - visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + GV%Z_to_H*(CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr + visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (cdrag_conv * umag_avg(i)) * h_bbl_fr endif h_sum = h_sum + h_at_vel(i,k) if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. @@ -1047,11 +1161,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) kv_bbl = max(CS%Kv_BBL_min, kv_bbl) if (m==1) then - visc%bbl_thick_u(I,j) = bbl_thick_Z - if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = GV%Z_to_H*kv_bbl + visc%bbl_thick_u(I,j) = bbl_thick + if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = kv_bbl else - visc%bbl_thick_v(i,J) = bbl_thick_Z - if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = GV%Z_to_H*kv_bbl + visc%bbl_thick_v(i,J) = bbl_thick + if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = kv_bbl endif endif ; enddo ! end of i loop enddo ; enddo ! end of m & j loops @@ -1204,12 +1318,15 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! Local variables real, dimension(SZIB_(G)) :: & - htot, & ! The total depth of the layers being that are within the + htot, & ! The total thickness of the layers that are within the ! surface mixed layer [H ~> m or kg m-2]. + dztot, & ! The distance from the surface to the bottom of the layers that are + ! within the surface mixed layer [Z ~> m] Thtot, & ! The integrated temperature of layers that are within the ! surface mixed layer [H C ~> m degC or kg degC m-2]. Shtot, & ! The integrated salt of layers that are within the ! surface mixed layer [H S ~> m ppt or kg ppt m-2]. + SpV_htot, & ! Running sum of thickness times specific volume [R-1 H ~> m4 kg-1 or m] Rhtot, & ! The integrated density of layers that are within the surface mixed layer ! [H R ~> kg m-2 or kg2 m-5]. Rhtot is only used if no ! equation of state is used. @@ -1222,19 +1339,30 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! (roughly the base of the mixed layer) with temperature [R C-1 ~> kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density at the base of layer nkml ! (roughly the base of the mixed layer) with salinity [R S-1 ~> kg m-3 ppt-1]. - ustar, & ! The surface friction velocity under ice shelves [Z T-1 ~> m s-1]. + dSpV_dT, & ! Partial derivative of the specific volume at the base of layer nkml + ! (roughly the base of the mixed layer) with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + dSpV_dS, & ! Partial derivative of the specific volume at the base of layer nkml + ! (roughly the base of the mixed layer) with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + ustar, & ! The surface friction velocity under ice shelves [H T-1 ~> m s-1 or kg m-2 s-1]. press, & ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. T_EOS, & ! The potential temperature at which dR_dT and dR_dS are evaluated [C ~> degC] S_EOS ! The salinity at which dR_dT and dR_dS are evaluated [S ~> ppt]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real, dimension(SZIB_(G),SZJ_(G)) :: & mask_u ! A mask that disables any contributions from u points that ! are land or past open boundary conditions [nondim], 0 or 1. real, dimension(SZI_(G),SZJB_(G)) :: & mask_v ! A mask that disables any contributions from v points that ! are land or past open boundary conditions [nondim], 0 or 1. + real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity in thickness-based units, + ! calculated using the Boussinesq reference density or the time-evolving + ! surface density in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] real :: h_at_vel(SZIB_(G),SZK_(GV))! Layer thickness at velocity points, ! using an upwind-biased second order accurate estimate based ! on the previous velocity direction [H ~> m or kg m-2]. + real :: dz_at_vel(SZIB_(G),SZK_(GV)) ! Vertical extent of a layer at velocity points, + ! using an upwind-biased second order accurate estimate based + ! on the previous velocity direction [Z ~> m]. integer :: k_massive(SZIB_(G)) ! The k-index of the deepest layer yet found ! that has more than h_tiny thickness and will be in the ! viscous mixed layer. @@ -1249,7 +1377,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real :: hweight ! The thickness of a layer that is within Hbbl ! of the bottom [H ~> m or kg m-2]. - real :: tbl_thick_Z ! The thickness of the top boundary layer [Z ~> m]. + real :: tbl_thick ! The thickness of the top boundary layer [Z ~> m]. real :: hlay ! The layer thickness at velocity points [H ~> m or kg m-2]. real :: I_2hlay ! 1 / 2*hlay [H-1 ~> m-1 or m2 kg-1]. @@ -1271,31 +1399,38 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. - real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion - ! factor from lateral lengths to vertical depths [Z L-1 ~> nondim] real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. + real :: cdrag_sqrt_H ! Square root of the drag coefficient, times a unit conversion + ! factor from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3]. + real :: cdrag_sqrt_H_RL ! Square root of the drag coefficient, times a unit conversion factor from + ! density times lateral lengths to layer thicknesses [H L-1 R-1 ~> m3 kg-1 or nondim] real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining ! the layer [H R ~> kg m-2 or kg2 m-5]. - real :: Dh ! The increment in layer thickness from - ! the present layer [H ~> m or kg m-2]. + real :: frac_used ! The fraction of the present layer that contributes to Dh and Ddz [nondim] + real :: Dh ! The increment in layer thickness from the present layer [H ~> m or kg m-2]. + real :: Ddz ! The increment in height change from the present layer [Z ~> m]. real :: U_bg_sq ! The square of an assumed background velocity, for ! calculating the mean magnitude near the top for use in ! the quadratic surface drag [L2 T-2 ~> m2 s-2]. real :: h_tiny ! A very small thickness [H ~> m or kg m-2]. Layers that are less than ! h_tiny can not be the deepest in the viscous mixed layer. real :: absf ! The absolute value of f averaged to velocity points [T-1 ~> s-1]. - real :: U_star ! The friction velocity at velocity points [Z T-1 ~> m s-1]. + real :: U_star ! The friction velocity at velocity points [H T-1 ~> m s-1 or kg m-2 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]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors - ! [R T2 H Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! [R T2 H-1 ~> kg s2 m-4 or s2 m-1]. ! The 400 is a constant proposed by Killworth and Edwards, 1999. real :: ustar1 ! ustar [H T-1 ~> m s-1 or kg m-2 s-1] real :: h2f2 ! (h*2*f)^2 [H2 T-2 ~> m2 s-2 or kg2 m-4 s-2] logical :: use_EOS, do_any, do_any_shelf, do_i(SZIB_(G)) + logical :: nonBous_ML ! If true, use the non-Boussinesq form of some energy and + ! stratification calculations. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, K2, nkmb, nkml, n type(ocean_OBC_type), pointer :: OBC => NULL() @@ -1309,22 +1444,28 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (.not.(CS%dynamic_viscous_ML .or. associated(forces%frac_shelf_u) .or. & associated(forces%frac_shelf_v)) ) return - Rho0x400_G = 400.0*(GV%Rho0/(US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H + Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel cdrag_sqrt = sqrt(CS%cdrag) - cdrag_sqrt_Z = US%L_to_Z * sqrt(CS%cdrag) + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H OBC => CS%OBC use_EOS = associated(tv%eqn_of_state) + nonBous_ML = allocated(tv%SpV_avg) dt_Rho0 = dt / GV%H_to_RZ h_neglect = GV%H_subroundoff h_tiny = 2.0*GV%Angstrom_H + h_neglect + dz_neglect = GV%dZ_subroundoff g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / (GV%Rho0) if (associated(forces%frac_shelf_u) .neqv. associated(forces%frac_shelf_v)) & call MOM_error(FATAL, "set_viscous_ML: one of forces%frac_shelf_u and "//& "forces%frac_shelf_v is associated, but the other is not.") + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) + if (associated(forces%frac_shelf_u)) then ! This configuration has ice shelves, and the appropriate variables need to be ! allocated. If the arrays have already been allocated, these calls do nothing. @@ -1342,7 +1483,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) allocate(visc%kv_tbl_shelf_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) ! With a linear drag law under shelves, the friction velocity is already known. -! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_H*CS%drag_bg_vel + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) endif !$OMP parallel do default(shared) @@ -1373,9 +1517,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) endif enddo ; endif - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & - !$OMP h_neglect,h_tiny,g_H_Rho0,js,je,OBC,Isq,Ieq,nz, & - !$OMP U_bg_sq,mask_v,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml) + !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & + !$OMP js,je,OBC,Isq,Ieq,nz,nkml,U_star_2d,U_bg_sq,mask_v, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) do j=js,je ! u-point loop if (CS%dynamic_viscous_ML) then do_any = .false. @@ -1396,8 +1541,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif - U_star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i+1,j))) - Idecay_len_TKE(I) = ((absf / U_star) * CS%TKE_decay) * GV%H_to_Z + U_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) + Idecay_len_TKE(I) = (absf / U_star) * CS%TKE_decay endif enddo @@ -1416,6 +1561,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, & (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) + if (nonBous_ML) then + call calculate_specific_vol_derivs(T_EOS, S_EOS, press, dSpV_dT, dSpV_dS, tv%eqn_of_state, & + (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) + endif endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1430,8 +1579,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (use_EOS) then T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k)) * I_2hlay S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k)) * I_2hlay - gHprime = g_H_Rho0 * (dR_dT(I) * (T_lay*htot(I) - Thtot(I)) + & - dR_dS(I) * (S_lay*htot(I) - Shtot(I))) + if (nonBous_ML) then + gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(I) * (Thtot(I) - T_lay*htot(I)) + & + dSpV_dS(I) * (Shtot(I) - S_lay*htot(I))) + else + gHprime = g_H_Rho0 * (dR_dT(I) * (T_lay*htot(I) - Thtot(I)) + & + dR_dS(I) * (S_lay*htot(I) - Shtot(I))) + endif else gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(I) - Rhtot(I)) endif @@ -1489,19 +1643,24 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (do_any_shelf) then do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then - if (u(I,j,k) *(h(i+1,j,k) - h(i,j,k)) >= 0) then + if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then h_at_vel(i,k) = 2.0*h(i,j,k)*h(i+1,j,k) / & (h(i,j,k) + h(i+1,j,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / & + (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) else h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) endif else - h_at_vel(I,k) = 0.0 ; ustar(I) = 0.0 + h_at_vel(I,k) = 0.0 + dz_at_vel(I,k) = 0.0 + ustar(I) = 0.0 endif ; enddo ; enddo do I=Isq,Ieq ; if (do_i(I)) then htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 - Thtot(I) = 0.0 ; Shtot(I) = 0.0 + Thtot(I) = 0.0 ; Shtot(I) = 0.0 ; SpV_htot(I) = 0.0 if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) @@ -1518,12 +1677,19 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Thtot(I) = Thtot(I) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k)) Shtot(I) = Shtot(I) + hweight * 0.5 * (tv%S(i,j,k) + tv%S(i+1,j,k)) endif + if (allocated(tv%SpV_avg)) then + SpV_htot(I) = SpV_htot(I) + hweight * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + endif enddo ; endif - if ((.not.CS%linear_drag) .and. (hwtot > 0.0)) then - ustar(I) = cdrag_sqrt_Z * hutot / hwtot - else - ustar(I) = cdrag_sqrt_Z * CS%drag_bg_vel + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(I) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(I) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot(I)) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(I) = cdrag_sqrt_H_RL * hutot / SpV_htot(I) + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(I) = cdrag_sqrt_H * hutot / hwtot endif if (use_EOS) then ; if (hwtot > 0.0) then @@ -1531,6 +1697,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) else T_EOS(I) = 0.0 ; S_EOS(I) = 0.0 endif ; endif + ! if (allocated(tv%SpV_avg)) SpV_av(I) = SpVhtot(I) / hwtot endif ; enddo ! I-loop if (use_EOS) then @@ -1542,7 +1709,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! The 400.0 in this expression is the square of a constant proposed ! by Killworth and Edwards, 1999, in equation (2.20). ustarsq = Rho0x400_G * ustar(i)**2 - htot(i) = 0.0 + htot(i) = 0.0 ; dztot(i) = 0.0 if (use_EOS) then Thtot(i) = 0.0 ; Shtot(i) = 0.0 do k=1,nz-1 @@ -1557,19 +1724,25 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) (h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Thtot(i) = Thtot(i) + T_Lay*Dh ; Shtot(i) = Shtot(i) + S_Lay*Dh enddo if ((oldfn < ustarsq) .and. (h_at_vel(i,nz) > 0.0)) then T_Lay = 0.5*(tv%T(i,j,nz) + tv%T(i+1,j,nz)) S_Lay = 0.5*(tv%S(i,j,nz) + tv%S(i+1,j,nz)) if (dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + & - dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) & + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! Examination of layer nz. else ! Use Rlay as the density variable. Rhtot = 0.0 @@ -1582,35 +1755,42 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Dfn = (Rlb - Rlay)*(h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Rhtot(i) = Rhtot(i) + Rlay*Dh enddo - if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! use_EOS - !visc%tbl_thick_shelf_u(I,j) = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ! htot(I) / (0.5 + sqrt(0.25 + & + ! visc%tbl_thick_shelf_u(I,j) = max(CS%Htbl_shelf_min, & + ! dztot(I) / (0.5 + sqrt(0.25 + & ! (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2 / & - ! (ustar(i)*GV%Z_to_H)**2 )) ) - ustar1 = ustar(i)*GV%Z_to_H + ! (ustar(i))**2 )) ) + ustar1 = ustar(i) h2f2 = (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) + h_neglect*CS%omega)**2 - tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ( htot(I)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) - visc%tbl_thick_shelf_u(I,j) = tbl_thick_Z - visc%Kv_tbl_shelf_u(I,j) = GV%Z_to_H*max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + tbl_thick = max(CS%Htbl_shelf_min, & + ( dztot(I)*ustar(i) ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) + visc%tbl_thick_shelf_u(I,j) = tbl_thick + visc%Kv_tbl_shelf_u(I,j) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar1*tbl_thick) endif ; enddo ! I-loop endif ! do_any_shelf enddo ! j-loop at u-points - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & - !$OMP h_neglect,h_tiny,g_H_Rho0,is,ie,OBC,Jsq,Jeq,nz, & - !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml,mask_u) + !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & + !$OMP is,ie,OBC,Jsq,Jeq,nz,nkml,U_bg_sq,U_star_2d,mask_u, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) do J=Jsq,Jeq ! v-point loop if (CS%dynamic_viscous_ML) then do_any = .false. @@ -1626,14 +1806,14 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) uhtot(i) = 0.25 * dt_Rho0 * ((forces%taux(I,j) + forces%taux(I-1,j+1)) + & (forces%taux(I-1,j) + forces%taux(I,j+1))) - if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else - absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - if (CS%omega_frac > 0.0) & - absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) - endif + if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + if (CS%omega_frac > 0.0) & + absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) + endif - U_star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i,j+1))) - Idecay_len_TKE(i) = ((absf / U_star) * CS%TKE_decay) * GV%H_to_Z + U_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) + Idecay_len_TKE(i) = (absf / U_star) * CS%TKE_decay endif enddo @@ -1653,6 +1833,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & tv%eqn_of_state, (/is-G%IsdB+1,ie-G%IsdB+1/) ) + if (nonBous_ML) then + call calculate_specific_vol_derivs(T_EOS, S_EOS, press, dSpV_dT, dSpV_dS, tv%eqn_of_state, & + (/is-G%IsdB+1,ie-G%IsdB+1/) ) + endif endif do i=is,ie ; if (do_i(i)) then @@ -1667,8 +1851,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (use_EOS) then T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k)) * I_2hlay S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k)) * I_2hlay - gHprime = g_H_Rho0 * (dR_dT(i) * (T_lay*htot(i) - Thtot(i)) + & - dR_dS(i) * (S_lay*htot(i) - Shtot(i))) + if (nonBous_ML) then + gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(i) * (Thtot(i) - T_lay*htot(i)) + & + dSpV_dS(i) * (Shtot(i) - S_lay*htot(i))) + else + gHprime = g_H_Rho0 * (dR_dT(i) * (T_lay*htot(i) - Thtot(i)) + & + dR_dS(i) * (S_lay*htot(i) - Shtot(i))) + endif else gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(i) - Rhtot(i)) endif @@ -1729,16 +1918,21 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (v(i,J,k) * (h(i,j+1,k) - h(i,j,k)) >= 0) then h_at_vel(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / & (h(i,j,k) + h(i,j+1,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / & + (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) else h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) endif else - h_at_vel(I,k) = 0.0 ; ustar(i) = 0.0 + h_at_vel(I,k) = 0.0 + dz_at_vel(I,k) = 0.0 + ustar(i) = 0.0 endif ; enddo ; enddo do i=is,ie ; if (do_i(i)) then htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 - Thtot(i) = 0.0 ; Shtot(i) = 0.0 + Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; SpV_htot(i) = 0.0 if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) @@ -1755,13 +1949,20 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Thtot(i) = Thtot(i) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) Shtot(i) = Shtot(i) + hweight * 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k)) endif + if (allocated(tv%SpV_avg)) then + SpV_htot(i) = SpV_htot(i) + hweight * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + endif enddo ; endif - if (.not.CS%linear_drag) then ; if (hwtot > 0.0) then - ustar(i) = cdrag_sqrt_Z * hutot / hwtot - else - ustar(i) = cdrag_sqrt_Z * CS%drag_bg_vel - endif ; endif + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(i) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot(i)) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(i) = cdrag_sqrt_H_RL * hutot / SpV_htot(i) + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(i) = cdrag_sqrt_H * hutot / hwtot + endif if (use_EOS) then ; if (hwtot > 0.0) then T_EOS(i) = Thtot(i)/hwtot ; S_EOS(i) = Shtot(i)/hwtot @@ -1780,6 +1981,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! by Killworth and Edwards, 1999, in equation (2.20). ustarsq = Rho0x400_G * ustar(i)**2 htot(i) = 0.0 + dztot(i) = 0.0 if (use_EOS) then Thtot(i) = 0.0 ; Shtot(i) = 0.0 do k=1,nz-1 @@ -1794,19 +1996,25 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) (h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Thtot(i) = Thtot(i) + T_Lay*Dh ; Shtot(i) = Shtot(i) + S_Lay*Dh enddo if ((oldfn < ustarsq) .and. (h_at_vel(i,nz) > 0.0)) then T_Lay = 0.5*(tv%T(i,j,nz) + tv%T(i,j+1,nz)) S_Lay = 0.5*(tv%S(i,j,nz) + tv%S(i,j+1,nz)) if (dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + & - dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) & + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! Examination of layer nz. else ! Use Rlay as the density variable. Rhtot = 0.0 @@ -1819,27 +2027,33 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Dfn = (Rlb - Rlay)*(h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Rhtot = Rhtot + Rlay*Dh enddo - if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! use_EOS - !visc%tbl_thick_shelf_v(i,J) = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ! htot(i) / (0.5 + sqrt(0.25 + & + ! visc%tbl_thick_shelf_v(i,J) = max(CS%Htbl_shelf_min, & + ! dztot(i) / (0.5 + sqrt(0.25 + & ! (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))**2 / & - ! (ustar(i)*GV%Z_to_H)**2 )) ) - ustar1 = ustar(i)*GV%Z_to_H + ! (ustar(i))**2 )) ) + ustar1 = ustar(i) h2f2 = (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)) + h_neglect*CS%omega)**2 - tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ( htot(i)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) - visc%tbl_thick_shelf_v(i,J) = tbl_thick_Z - visc%Kv_tbl_shelf_v(i,J) = GV%Z_to_H*max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + tbl_thick = max(CS%Htbl_shelf_min, & + ( dztot(i)*ustar(i) ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) + visc%tbl_thick_shelf_v(i,J) = tbl_thick + visc%Kv_tbl_shelf_v(i,J) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar1*tbl_thick) endif ; enddo ! i-loop endif ! do_any_shelf @@ -1873,6 +2087,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) logical :: use_CVMix_shear, MLE_use_PBL_MLD, MLE_use_Bodner, use_CVMix_conv integer :: isd, ied, jsd, jed, nz real :: hfreeze !< If hfreeze > 0 [Z ~> m], melt potential will be computed. + character(len=16) :: Kv_units, Kd_units character(len=40) :: mdl = "MOM_set_visc" ! This module's name. isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -1897,25 +2112,31 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) "in the surface boundary layer.", default=.false., do_not_log=.true.) endif + if (GV%Boussinesq) then + Kv_units = "m2 s-1" ; Kd_units = "m2 s-1" + else + Kv_units = "Pa s" ; Kd_units = "kg m-1 s-1" + endif + if (use_kappa_shear .or. useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv) then call safe_alloc_ptr(visc%Kd_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kd_shear, "Kd_shear", .false., restart_CS, & "Shear-driven turbulent diffusivity at interfaces", & - units="m2 s-1", conversion=GV%HZ_T_to_m2_s, z_grid='i') + units=Kd_units, conversion=GV%HZ_T_to_MKS, z_grid='i') endif if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. & (use_kappa_shear .and. .not.KS_at_vertex )) then call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, & "Shear-driven turbulent viscosity at interfaces", & - units="m2 s-1", conversion=GV%HZ_T_to_m2_s, z_grid='i') + units=Kv_units, conversion=GV%HZ_T_to_MKS, z_grid='i') endif if (use_kappa_shear .and. KS_at_vertex) then call safe_alloc_ptr(visc%TKE_turb, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call safe_alloc_ptr(visc%Kv_shear_Bu, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call register_restart_field(visc%Kv_shear_Bu, "Kv_shear_Bu", .false., restart_CS, & "Shear-driven turbulent viscosity at vertex interfaces", & - units="m2 s-1", conversion=GV%HZ_T_to_m2_s, hor_grid="Bu", z_grid='i') + units=Kv_units, conversion=GV%HZ_T_to_MKS, hor_grid="Bu", z_grid='i') elseif (use_kappa_shear) then call safe_alloc_ptr(visc%TKE_turb, isd, ied, jsd, jed, nz+1) endif @@ -1932,14 +2153,13 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) call get_param(param_file, mdl, "HFREEZE", hfreeze, & units="m", default=-1.0, scale=US%m_to_Z, do_not_log=.true.) - if (MLE_use_PBL_MLD) then + if (hfreeze >= 0.0 .or. MLE_use_PBL_MLD) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) - call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & - "Instantaneous active mixing layer depth", "m", conversion=US%Z_to_m) endif - if (hfreeze >= 0.0 .and. .not.MLE_use_PBL_MLD) then - call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) + if (MLE_use_PBL_MLD) then + call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & + "Instantaneous active mixing layer depth", units="m", conversion=US%Z_to_m) endif ! visc%sfc_buoy_flx is used to communicate the state of the (e)PBL or KPP to the rest of the model @@ -2009,8 +2229,6 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS ! is used in place of the absolute value of the local Coriolis ! parameter in the denominator of some expressions [nondim] real :: Chan_max_thick_dflt ! The default value for CHANNEL_DRAG_MAX_THICK [Z ~> m] - real :: Hbbl ! The static bottom boundary layer thickness [Z ~> m]. - real :: BBL_thick_min ! The minimum bottom boundary layer thickness [Z ~> m]. integer :: i, j, k, is, ie, js, je integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz @@ -2140,14 +2358,14 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "The rotation rate of the earth.", & units="s-1", default=7.2921e-5, scale=US%T_to_s) ! This give a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) + CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_H + GV%H_subroundoff) else call get_param(param_file, mdl, "OMEGA", CS%omega, & "The rotation rate of the earth.", & units="s-1", default=7.2921e-5, scale=US%T_to_s) endif - call get_param(param_file, mdl, "HBBL", Hbbl, & + call get_param(param_file, mdl, "HBBL", CS%dz_bbl, & "The thickness of a bottom boundary layer with a viscosity increased by "//& "KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which "//& "near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//& @@ -2192,7 +2410,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (use_regridding .and. (.not. CS%BBL_use_EOS)) & call MOM_error(FATAL,"When using MOM6 in ALE mode it is required to set BBL_USE_EOS to True.") endif - call get_param(param_file, mdl, "BBL_THICK_MIN", BBL_thick_min, & + call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & "The minimum bottom boundary layer thickness that can be "//& "used with BOTTOMDRAGLAW. This might be "//& "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& @@ -2201,12 +2419,12 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "The minimum top boundary layer thickness that can be "//& "used with BOTTOMDRAGLAW. This might be "//& "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& - "near-top viscosity.", units="m", default=US%Z_to_m*BBL_thick_min, scale=GV%m_to_H) + "near-top viscosity.", units="m", default=US%Z_to_m*CS%BBL_thick_min, scale=US%m_to_Z) call get_param(param_file, mdl, "HTBL_SHELF", CS%Htbl_shelf, & "The thickness over which near-surface velocities are "//& "averaged for the drag law under an ice shelf. By "//& "default this is the same as HBBL", & - units="m", default=US%Z_to_m*Hbbl, scale=GV%m_to_H) + units="m", default=US%Z_to_m*CS%dz_bbl, scale=GV%m_to_H) call get_param(param_file, mdl, "KV", Kv_background, & "The background kinematic viscosity in the interior. "//& @@ -2220,10 +2438,10 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "KV_BBL_MIN", CS%KV_BBL_min, & "The minimum viscosities in the bottom boundary layer.", & - units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KV_TBL_MIN", CS%KV_TBL_min, & "The minimum viscosities in the top boundary layer.", & - units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "CORRECT_BBL_BOUNDS", CS%correct_BBL_bounds, & "If true, uses the correct bounds on the BBL thickness and "//& "viscosity so that the bottom layer feels the intended drag.", & @@ -2246,21 +2464,20 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS endif Chan_max_thick_dflt = -1.0*US%m_to_Z - if (CS%RiNo_mix) Chan_max_thick_dflt = 0.5*Hbbl - if (CS%body_force_drag) Chan_max_thick_dflt = Hbbl + if (CS%RiNo_mix) Chan_max_thick_dflt = 0.5*CS%dz_bbl + if (CS%body_force_drag) Chan_max_thick_dflt = CS%dz_bbl call get_param(param_file, mdl, "CHANNEL_DRAG_MAX_BBL_THICK", CS%Chan_drag_max_vol, & "The maximum bottom boundary layer thickness over which the channel drag is "//& "exerted, or a negative value for no fixed limit, instead basing the BBL "//& "thickness on the bottom stress, rotation and stratification. The default is "//& "proportional to HBBL if USE_JACKSON_PARAM or DRAG_AS_BODY_FORCE is true.", & - units="m", default=US%Z_to_m*Chan_max_thick_dflt, scale=GV%m_to_H, & + units="m", default=US%Z_to_m*Chan_max_thick_dflt, scale=US%m_to_Z, & do_not_log=.not.CS%Channel_drag) call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & default=.false., do_not_log=.true.) - CS%Hbbl = Hbbl * GV%Z_to_H ! Rescaled for later use - CS%BBL_thick_min = BBL_thick_min * GV%Z_to_H ! Rescaled for later use + CS%Hbbl = CS%dz_bbl * (US%Z_to_m * GV%m_to_H) ! Rescaled for use in expressions in thickness units. if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then ! This is necessary for reproducibility across restarts in non-symmetric mode. From 9b86edb3d8f0acb13cfaa610cad17b4a740d7bd2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 12 Aug 2023 11:55:57 -0400 Subject: [PATCH 056/146] *Non-Boussinesq revision of set_diffusivity This commit revises the internal routines called by set_diffusivity to work in fully non-Boussinesq mode, eliminating all dependencies on the Boussinesq reference density when in non-Boussinesq mode. The publicly visible interfaces to this module and the external routines it calls have already been revised, so only this file needs to be updated. The specific changes include: - Refactored add_LOTW_BBL_diffusivity, add_MLrad_diffusivity, and set_BBL_TKE to work in units of layer vertical extent rather than layer thickness to give results in non-Boussinesq mode that avoid dependence on the Boussinesq reference density. - Work with internal variables in vertical distances in the denominator of diffusive flux calculations in find_TKE_to_Kd, while other expressions in this routine are recast in terms of thicknesses to avoid conversions. - Use tv%SpV_avg instead of 1/RHO_0 in find_TKE_to_Kd when in fully non-Boussinesq mode. - Use layer target density differences in place of g_prime in set_density_ratios in mathematically equivalent expressions when non-Boussinesq. - Use thickness_to_dz in 3 places to convert layer thicknesses into vertical distances. - The thickness argument to add_MLrad_diffusivity (in [H ~> m or kg m-2]) has been replaced with a vertical extent argument (in [Z ~> m]). - Use fluxes%tau_mag in place of fluxes%ustar in add_MLrad_diffusivity when in non-Boussinesq or semi-Boussinesq mode. There is a new thermo_var_ptrs type argument to the internal routine add_MLrad_diffusivity to permit this changes. - Use the in situ near-bottom density when adding certain contributions to non-Boussinesq diffusivities. This change includes the addition of a new bottom density (rho_bot) argument to add_int_tide_diffusivity, add_LOTW_BBL_diffusivity and add_drag_diffusivity. - Use GV%dZ_subroundoff in 4 spots in place of GV%H_to_Z*GV%H_subroundoff. - A long-standing comment questioning whether there is double-counting of tidal mixing has been addressed (there is not) and the comment has been revised accordingly. These changes involved changing the units of 21 internal variables and 1 element in the set_diffusivity_CS type. There are 11 new internal variables, while 9 internal variables were eliminated. A total of 44 thickness rescaling factors were eliminated, and there are 2 places where GV%Rho_0 was being used explicitly that were changed into equivalent rescaling factors. All answers are bitwise identical in Boussinesq mode, but some solutions will change in non-Boussinesq mode with this commit. --- .../vertical/MOM_set_diffusivity.F90 | 341 ++++++++++-------- 1 file changed, 200 insertions(+), 141 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 2aac478086..c792f5200e 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -80,8 +80,8 @@ module MOM_set_diffusivity real :: cdrag !< quadratic drag coefficient [nondim] real :: dz_BBL_avg_min !< A minimal distance over which to average to determine the average !! bottom boundary layer density [Z ~> m] - real :: IMax_decay !< inverse of a maximum decay scale for - !! bottom-drag driven turbulence [Z-1 ~> m-1]. + real :: IMax_decay !< Inverse of a maximum decay scale for + !! bottom-drag driven turbulence [H-1 ~> m-1 or m2 kg-1]. real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -505,8 +505,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif ! Add the ML_Rad diffusivity. - if (CS%ML_radiation) & - call add_MLrad_diffusivity(h, fluxes, j, Kd_int_2d, G, GV, US, CS, TKE_to_Kd, Kd_lay_2d) + if (CS%ML_radiation) then + call add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int_2d, G, GV, US, CS, TKE_to_Kd, Kd_lay_2d) + endif ! Add the Nikurashin and / or tidal bottom-driven mixing if (CS%use_tidal_mixing) & @@ -517,11 +518,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then - call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int_2d, G, GV, US, CS, & - dd%Kd_BBL, Kd_lay_2d) + call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bot, Kd_int_2d, & + G, GV, US, CS, dd%Kd_BBL, Kd_lay_2d) else call add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & - maxTKE, kb, G, GV, US, CS, Kd_lay_2d, Kd_int_2d, dd%Kd_BBL) + maxTKE, kb, rho_bot, G, GV, US, CS, Kd_lay_2d, Kd_int_2d, dd%Kd_BBL) endif endif @@ -567,7 +568,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (associated(dd%Kd_work)) then do k=1,nz ; do i=is,ie - dd%Kd_Work(i,j,k) = GV%H_to_RZ * Kd_lay_2d(i,k) * N2_lay(i,k) * GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 + dd%Kd_Work(i,j,k) = GV%H_to_RZ * Kd_lay_2d(i,k) * N2_lay(i,k) * dz(i,k) ! Watt m-2 = kg s-3 enddo ; enddo endif @@ -697,27 +698,30 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! across an interface times the difference across the ! interface above it [nondim] rho_0, & ! Layer potential densities relative to surface pressure [R ~> kg m-3] + dz, & ! Height change across layers [Z ~> m] maxEnt ! maxEnt is the maximum value of entrainment from below (with ! compensating entrainment from above to keep the layer ! density from changing) that will not deplete all of the - ! layers above or below a layer within a timestep [Z ~> m]. + ! layers above or below a layer within a timestep [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. - mFkb, & ! total thickness in the mixed and buffer layers times ds_dsp1 [Z ~> m]. + ! integrated thickness in the BBL [H ~> m or kg m-2]. + mFkb, & ! total thickness in the mixed and buffer layers times ds_dsp1 [H ~> m or kg m-2] p_ref, & ! array of tv%P_Ref pressures [R L2 T-2 ~> Pa] Rcv_kmb, & ! coordinate density in the lowest buffer layer [R ~> kg m-3] p_0 ! An array of 0 pressures [R L2 T-2 ~> Pa] real :: dh_max ! maximum amount of entrainment a layer could undergo before - ! entraining all fluid in the layers above or below [Z ~> m]. + ! entraining all fluid in the layers above or below [H ~> m or kg m-2] real :: dRho_lay ! density change across a layer [R ~> kg m-3] real :: Omega2 ! rotation rate squared [T-2 ~> s-2] - real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density [Z T-2 R-1 ~> m4 s-2 kg-1] - real :: G_IRho0 ! Alternate calculation of G_Rho0 for reproducibility [Z T-2 R-1 ~> m4 s-2 kg-1] - real :: I_Rho0 ! inverse of Boussinesq reference density [R-1 ~> m3 kg-1] + real :: grav ! Gravitational acceleration [Z T-1 ~> m s-2] + real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density + ! [Z R-1 T-2 ~> m4 s-2 kg-1] + real :: G_IRho0 ! Alternate calculation of G_Rho0 with thickness rescaling factors + ! [Z2 T-2 R-1 H-1 ~> m4 s-2 kg-1 or m7 kg-2 s-2] real :: I_dt ! 1/dt [T-1 ~> s-1] - real :: H_neglect ! negligibly small thickness [H ~> m or kg m-2] + real :: dz_neglect ! A negligibly small height change [Z ~> m] real :: hN2pO2 ! h (N^2 + Omega^2), in [Z T-2 ~> m s-2]. logical :: do_i(SZI_(G)) @@ -727,22 +731,25 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & I_dt = 1.0 / dt Omega2 = CS%omega**2 - H_neglect = GV%H_subroundoff - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) + dz_neglect = GV%dZ_subroundoff + grav = (US%L_to_Z**2 * GV%g_Earth) + G_Rho0 = grav / GV%Rho0 if (CS%answer_date < 20190101) then - I_Rho0 = 1.0 / (GV%Rho0) - G_IRho0 = (US%L_to_Z**2 * GV%g_Earth) * I_Rho0 + G_IRho0 = grav * GV%H_to_Z**2 * GV%RZ_to_H else - G_IRho0 = G_Rho0 + G_IRho0 = GV%H_to_Z*G_Rho0 endif + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + ! Simple but coordinate-independent estimate of Kd/TKE if (CS%simple_TKE_to_Kd) then do k=1,nz ; do i=is,ie - hN2pO2 = (GV%H_to_Z * h(i,j,k)) * (N2_lay(i,k) + Omega2) ! Units of Z T-2. - if (hN2pO2>0.) then - TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of T2 Z-1. - else; TKE_to_Kd(i,k) = 0.; endif + hN2pO2 = dz(i,k) * (N2_lay(i,k) + Omega2) ! Units of Z T-2. + if (hN2pO2 > 0.) then + TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of T2 H-1. + else ; TKE_to_Kd(i,k) = 0. ; endif ! The maximum TKE conversion we allow is really a statement ! about the upper diffusivity we allow. Kd_max must be set. maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of H Z2 T-3. @@ -793,18 +800,17 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & if (CS%bulkmixedlayer) then kmb = GV%nk_rho_varies do i=is,ie - htot(i) = GV%H_to_Z*h(i,j,kmb) + htot(i) = h(i,j,kmb) mFkb(i) = 0.0 - if (kb(i) < nz) & - mFkb(i) = ds_dsp1(i,kb(i)) * (GV%H_to_Z*(h(i,j,kmb) - GV%Angstrom_H)) + if (kb(i) < nz) mFkb(i) = ds_dsp1(i,kb(i)) * (h(i,j,kmb) - GV%Angstrom_H) enddo do k=1,kmb-1 ; do i=is,ie - htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) - mFkb(i) = mFkb(i) + ds_dsp1(i,k+1)*(GV%H_to_Z*(h(i,j,k) - GV%Angstrom_H)) + htot(i) = htot(i) + h(i,j,k) + mFkb(i) = mFkb(i) + ds_dsp1(i,k+1)*(h(i,j,k) - GV%Angstrom_H) enddo ; enddo else do i=is,i - maxEnt(i,1) = 0.0 ; htot(i) = GV%H_to_Z*(h(i,j,1) - GV%Angstrom_H) + maxEnt(i,1) = 0.0 ; htot(i) = h(i,j,1) - GV%Angstrom_H enddo endif do k=kb_min,nz-1 ; do i=is,ie @@ -816,12 +822,12 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & else maxEnt(i,k) = ds_dsp1(i,k)*(maxEnt(i,k-1) + htot(i)) endif - htot(i) = htot(i) + GV%H_to_Z*(h(i,j,k) - GV%Angstrom_H) + htot(i) = htot(i) + (h(i,j,k) - GV%Angstrom_H) endif enddo ; enddo do i=is,ie - htot(i) = GV%H_to_Z*(h(i,j,nz) - GV%Angstrom_H) ; maxEnt(i,nz) = 0.0 + htot(i) = h(i,j,nz) - GV%Angstrom_H ; maxEnt(i,nz) = 0.0 do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz-1,kb_min,-1 @@ -829,8 +835,8 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & do i=is,ie ; if (do_i(i)) then if (k This routine adds diffusion sustained by flow energy extracted by bottom drag. subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, & - kb, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) + kb, rho_bot, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) 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 @@ -1171,6 +1183,8 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, !! maximum-realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer + real, dimension(SZI_(G)), intent(in) :: rho_bot !< In situ density averaged over a near-bottom + !! region [R ~> kg m-3] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers, !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -1185,23 +1199,24 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, Rint ! coordinate density of an interface [R ~> kg m-3] real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. - rho_htot, & ! running integral with depth of density [R Z ~> kg m-2] + ! integrated thickness in the BBL [H ~> m or kg m-2]. + rho_htot, & ! running integral with depth of density [R H ~> kg m-2 or kg2 m-5] gh_sum_top, & ! BBL value of g'h that can be supported by - ! the local ustar, times R0_g [R Z ~> kg m-2] + ! the local ustar, times R0_g [R H ~> kg m-2 or kg2 m-5] Rho_top, & ! density at top of the BBL [R ~> kg m-3] TKE, & ! turbulent kinetic energy available to drive ! bottom-boundary layer mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] - I2decay ! inverse of twice the TKE decay scale [Z-1 ~> m-1]. + I2decay ! inverse of twice the TKE decay scale [H-1 ~> m-1 or m2 kg-1]. real :: TKE_to_layer ! TKE used to drive mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_here ! TKE that goes into mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: dRl, dRbot ! temporaries holding density differences [R ~> kg m-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar_h ! value of ustar at a thickness point [Z T-1 ~> m s-1]. + real :: ustar_h ! Ustar at a thickness point rescaled into thickness + ! flux units [H T-1 ~> m s-1 or kg m-2 s-1]. real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] - real :: R0_g ! Rho0 / G_Earth [R T2 Z-1 ~> kg s2 m-4] + real :: R0_g ! Rho0 / G_Earth [R T2 H-1 ~> kg s2 m-4 or s2 m-1] real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this @@ -1221,7 +1236,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, TKE_Ray = 0.0 ; Rayleigh_drag = .false. if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. - R0_g = GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) + R0_g = GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth) do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo @@ -1231,9 +1246,14 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, ! Any turbulence that makes it into the mixed layers is assumed ! to be relatively small and is discarded. do i=is,ie - ustar_h = GV%H_to_Z*visc%ustar_BBL(i,j) - if (associated(fluxes%ustar_tidal)) & - ustar_h = ustar_h + fluxes%ustar_tidal(i,j) + ustar_h = visc%ustar_BBL(i,j) + if (associated(fluxes%ustar_tidal)) then + if (allocated(tv%SpV_avg)) then + ustar_h = ustar_h + GV%RZ_to_H*rho_bot(i) * fluxes%ustar_tidal(i,j) + else + ustar_h = ustar_h + GV%Z_to_H * fluxes%ustar_tidal(i,j) + endif + endif absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) if ((ustar_h > 0.0) .and. (absf > 0.5*CS%IMax_decay*ustar_h)) then @@ -1243,12 +1263,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, ! If ustar_h = 0, this is land so this value doesn't matter. I2decay(i) = 0.5*CS%IMax_decay endif - TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & - visc%TKE_BBL(i,j) + TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*h(i,j,nz)) ) * visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * GV%RZ_to_H * & - (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz)))) + (CS%BBL_effic * exp(-I2decay(i)*h(i,j,nz))) ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following ! Killworth & Edwards (1999) and Zilitikevich & Mironov (1996). @@ -1258,16 +1277,16 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, gh_sum_top(i) = R0_g * 400.0 * ustar_h**2 do_i(i) = (G%mask2dT(i,j) > 0.0) - htot(i) = GV%H_to_Z*h(i,j,nz) - rho_htot(i) = GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) + htot(i) = h(i,j,nz) + rho_htot(i) = GV%Rlay(nz)*(h(i,j,nz)) Rho_top(i) = GV%Rlay(1) if (CS%bulkmixedlayer .and. do_i(i)) Rho_top(i) = GV%Rlay(kb(i)-1) enddo do k=nz-1,2,-1 ; domore = .false. do i=is,ie ; if (do_i(i)) then - htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) - rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(GV%H_to_Z*h(i,j,k)) + htot(i) = htot(i) + h(i,j,k) + rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(h(i,j,k)) if (htot(i)*GV%Rlay(k-1) <= (rho_htot(i) - gh_sum_top(i))) then ! The top of the mixing is in the interface atop the current layer. Rho_top(i) = (rho_htot(i) - gh_sum_top(i)) / htot(i) @@ -1286,9 +1305,8 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, i_rem = i_rem + 1 ! Count the i-rows that are still being worked on. ! Apply vertical decay of the turbulent energy. This energy is ! simply lost. - TKE(i) = TKE(i) * exp(-I2decay(i) * (GV%H_to_Z*(h(i,j,k) + h(i,j,k+1)))) + TKE(i) = TKE(i) * exp(-I2decay(i) * (h(i,j,k) + h(i,j,k+1))) -! if (maxEnt(i,k) <= 0.0) cycle if (maxTKE(i,k) <= 0.0) cycle ! This is an analytic integral where diffusivity is a quadratic function of @@ -1377,7 +1395,7 @@ end subroutine add_drag_diffusivity !> Calculates a BBL diffusivity use a Prandtl number 1 diffusivity with a law of the !! wall turbulent viscosity, up to a BBL height where the energy used for mixing has !! consumed the mechanical TKE input. -subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int, & +subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bot, Kd_int, & G, GV, US, CS, Kd_BBL, Kd_lay) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -1396,6 +1414,8 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] + real, dimension(SZI_(G)), intent(in) :: rho_bot !< In situ density averaged over a near-bottom + !! region [R ~> kg m-3] real, dimension(SZI_(G),SZK_(GV)+1), & intent(inout) :: Kd_int !< Interface net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure @@ -1404,26 +1424,29 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int optional, intent(inout) :: Kd_lay !< Layer net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: TKE_column ! net TKE input into the column [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_consumed ! TKE used for mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [H Z2 T-3 ~> m3 s-3 or W m-2] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar ! value of ustar at a thickness point [Z T-1 ~> m s-1]. - real :: ustar2 ! square of ustar, for convenience [Z2 T-2 ~> m2 s-2] + real :: ustar ! value of ustar at a thickness point [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: ustar2 ! The square of ustar [H2 T-2 ~> m2 s-2 or kg2 m-4 s-2] real :: absf ! average absolute value of Coriolis parameter around a thickness point [T-1 ~> s-1] - real :: dh, dhm1 ! thickness of layers k and k-1, respectively [Z ~> m]. - real :: z_bot ! distance to interface k from bottom [Z ~> m]. - real :: D_minus_z ! distance to interface k from surface [Z ~> m]. - real :: total_thickness ! total thickness of water column [Z ~> m]. - real :: Idecay ! inverse of decay scale used for "Joule heating" loss of TKE with height [Z-1 ~> m-1]. + real :: dz_int ! Distance between the center of the layers around an interface [Z ~> m] + real :: z_bot ! Distance to interface K from bottom [Z ~> m] + real :: h_bot ! Total thickness between interface K and the bottom [H ~> m or kg m-2] + real :: D_minus_z ! Distance between interface k and the surface [Z ~> m] + real :: total_depth ! Total distance between the seafloor and the sea surface [Z ~> m] + real :: Idecay ! Inverse of decay scale used for "Joule heating" loss of TKE with + ! height [H-1 ~> m-1 or m2 kg-1]. real :: Kd_wall ! Law of the wall diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: Kd_lower ! diffusivity for lower interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. + real :: ustar_D ! The extent of the water column times u* [H Z T-1 ~> m2 s-1 or Pa s]. real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] logical :: Rayleigh_drag ! Set to true if there are Rayleigh drag velocities defined in visc, on ! the assumption that this extracted energy also drives diapycnal mixing. - integer :: i, k, km1 + integer :: i, k logical :: do_diag_Kd_BBL if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return @@ -1437,19 +1460,28 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. cdrag_sqrt = sqrt(CS%cdrag) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=G%isc,G%iec ! Developed in single-column mode ! Column-wise parameters. absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! - ! u* at the bottom [Z T-1 ~> m s-1]. - ustar = GV%H_to_Z*visc%ustar_BBL(i,j) + ! u* at the bottom [H T-1 ~> m s-1 or kg m-2 s-1]. + ustar = visc%ustar_BBL(i,j) ustar2 = ustar**2 - ! In add_drag_diffusivity(), fluxes%ustar_tidal is added in. This might be double counting - ! since ustar_BBL should already include all contributions to u*? -AJA - !### Examine the question of whether there is double counting of fluxes%ustar_tidal. - if (associated(fluxes%ustar_tidal)) ustar = ustar + fluxes%ustar_tidal(i,j) + ! In add_drag_diffusivity(), fluxes%ustar_tidal is also added in. There is no + ! double-counting because the logic surrounding the calls to add_drag_diffusivity() + ! and add_LOTW_BBL_diffusivity() only calls one of the two routines. + if (associated(fluxes%ustar_tidal)) then + if (allocated(tv%SpV_avg)) then + ustar = ustar + GV%RZ_to_H*rho_bot(i) * fluxes%ustar_tidal(i,j) + else + ustar = ustar + GV%Z_to_H * fluxes%ustar_tidal(i,j) + endif + endif ! The maximum decay scale should be something of order 200 m. We use the smaller of u*/f and ! (IMax_decay)^-1 as the decay scale. If ustar = 0, this is land so this value doesn't matter. @@ -1467,17 +1499,16 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column - total_thickness = ( sum(h(i,j,:)) + GV%H_subroundoff )* GV%H_to_Z ! Total column thickness [Z ~> m]. - ustar_D = ustar * total_thickness + total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + ustar_D = ustar * total_depth + h_bot = 0. z_bot = 0. Kd_lower = 0. ! Diffusivity on bottom boundary. ! Work upwards from the bottom, accumulating work used until it exceeds the available TKE input ! at the bottom. - do k=GV%ke,2,-1 - dh = GV%H_to_Z * h(i,j,k) ! Thickness of this level [Z ~> m]. - km1 = max(k-1, 1) - dhm1 = GV%H_to_Z * h(i,j,km1) ! Thickness of level above [Z ~> m]. + do K=GV%ke,2,-1 + dz_int = 0.5 * (dz(i,k-1) + dz(i,k)) ! Add in additional energy input from bottom-drag against slopes (sides) if (Rayleigh_drag) TKE_remaining = TKE_remaining + & @@ -1489,23 +1520,24 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int ! Exponentially decay TKE across the thickness of the layer. ! This is energy loss in addition to work done as mixing, apparently to Joule heating. - TKE_remaining = exp(-Idecay*dh) * TKE_remaining + TKE_remaining = exp(-Idecay*h(i,j,k)) * TKE_remaining - z_bot = z_bot + h(i,j,k)*GV%H_to_Z ! Distance between upper interface of layer and the bottom [Z ~> m]. - D_minus_z = max(total_thickness - z_bot, 0.) ! Thickness above layer [Z ~> m]. + z_bot = z_bot + dz(i,k) ! Distance between upper interface of layer and the bottom [Z ~> m]. + h_bot = h_bot + h(i,j,k) ! Thickness between upper interface of layer and the bottom [H ~> m or kg m-2]. + D_minus_z = max(total_depth - z_bot, 0.) ! Thickness above layer [H ~> m or kg m-2]. - ! Diffusivity using law of the wall, limited by rotation, at height z [Z2 T-1 ~> m2 s-1]. + ! Diffusivity using law of the wall, limited by rotation, at height z [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This calculation is at the upper interface of the layer - if ( ustar_D + absf * ( z_bot * D_minus_z ) == 0.) then + if ( ustar_D + absf * ( h_bot * D_minus_z ) == 0.) then Kd_wall = 0. else - Kd_wall = ((GV%Z_to_H*CS%von_karm * ustar2) * (z_bot * D_minus_z)) & - / (ustar_D + absf * (z_bot * D_minus_z)) + Kd_wall = ((CS%von_karm * ustar2) * (z_bot * D_minus_z)) & + / (ustar_D + absf * (h_bot * D_minus_z)) endif ! TKE associated with Kd_wall [H Z2 T-3 ~> m3 s-3 or W m-2]. - ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + ! This calculation is for the volume spanning the interface. + TKE_Kd_wall = Kd_wall * dz_int * max(N2_int(i,K), N2_min) ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. if (TKE_Kd_wall > 0.) then @@ -1535,13 +1567,14 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int end subroutine add_LOTW_BBL_diffusivity !> This routine adds effects of mixed layer radiation to the layer diffusivities. -subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_lay) +subroutine add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_lay) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< Height change across layers [Z ~> m] type(forcing), intent(in) :: fluxes !< Surface fluxes structure + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -1557,24 +1590,26 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! This routine adds effects of mixed layer radiation to the layer diffusivities. - real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. + real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m] real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [H Z2 T-3 ~> m3 s-3 or W m-2] - real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. + real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: f_sq ! The square of the local Coriolis parameter or a related variable [T-2 ~> s-2]. - real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2]. + real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2] + real :: u_star_H ! ustar converted to thickness based units [H T-1 ~> m s-1 or kg m-2 s-1] real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] real :: C1_6 ! 1/6 [nondim] real :: Omega2 ! rotation rate squared [T-2 ~> s-2]. real :: z1 ! layer thickness times I_decay [nondim] - real :: dzL ! thickness converted to heights [Z ~> m]. - real :: I_decay_len2_TKE ! squared inverse decay lengthscale for - ! TKE, as used in the mixed layer code [Z-2 ~> m-2]. - real :: h_neglect ! negligibly small thickness [Z ~> m]. + real :: I_decay_len2_TKE ! Squared inverse decay lengthscale for TKE from the bulk mixed + ! layer code [Z-2 ~> m-2] + real :: dz_neglect ! A negligibly small height change [Z ~> m] logical :: do_any, do_i(SZI_(G)) integer :: i, k, is, ie, nz, kml @@ -1583,12 +1618,13 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Omega2 = CS%omega**2 C1_6 = 1.0 / 6.0 kml = GV%nkml - h_neglect = GV%H_subroundoff*GV%H_to_Z + dz_neglect = GV%dz_subroundoff + I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 ! This is not used when fully non-Boussinesq. if (.not.CS%ML_radiation) return do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo - do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + GV%H_to_Z*h(i,j,k) ; enddo ; enddo + do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + dz(i,k) ; enddo ; enddo do i=is,ie ; if (do_i(i)) then if (CS%ML_omega_frac >= 1.0) then @@ -1600,21 +1636,31 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, f_sq = CS%ML_omega_frac * 4.0 * Omega2 + (1.0 - CS%ML_omega_frac) * f_sq endif - ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 - - TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * (GV%Z_to_H*fluxes%ustar(i,j))) + ! Determine the energy flux out of the mixed layer and its vertical decay scale. + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 + u_star_H = GV%Z_to_H * fluxes%ustar(i,j) + elseif (allocated(tv%SpV_avg)) then + ustar_sq = max(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1), CS%ustar_min**2) + u_star_H = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + else ! This semi-Boussinesq form is mathematically equivalent to the Boussinesq version above. + ! Differs at roundoff: ustar_sq = max(fluxes%tau_mag(i,j) * I_rho, CS%ustar_min**2) + ustar_sq = max((sqrt(fluxes%tau_mag(i,j) * I_rho))**2, CS%ustar_min**2) + u_star_H = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) * GV%Rho0) + endif + TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * u_star_H) I_decay_len2_TKE = CS%TKE_decay**2 * (f_sq / ustar_sq) if (CS%ML_rad_TKE_decay) & TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-h_ml(i) * sqrt(I_decay_len2_TKE)) ! Calculate the inverse decay scale - h_ml_sq = (CS%ML_rad_efold_coeff * (h_ml(i)+h_neglect))**2 + h_ml_sq = (CS%ML_rad_efold_coeff * (h_ml(i)+dz_neglect))**2 I_decay(i) = sqrt((I_decay_len2_TKE * h_ml_sq + 1.0) / h_ml_sq) ! Average the dissipation layer kml+1, using ! a more accurate Taylor series approximations for very thin layers. - z1 = (GV%H_to_Z*h(i,j,kml+1)) * I_decay(i) + z1 = dz(i,kml+1) * I_decay(i) if (z1 > 1e-5) then Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) else @@ -1639,14 +1685,14 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, do k=kml+2,nz-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dzL = GV%H_to_Z*h(i,j,k) ; z1 = dzL*I_decay(i) + z1 = dz(i,k)*I_decay(i) if (CS%ML_Rad_bug) then ! These expressions are dimensionally inconsistent. -RWH ! This is supposed to be the integrated energy deposited in the layer, ! not the average over the layer as in these expressions. if (z1 > 1e-5) then Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 - US%m_to_Z * ((1.0 - exp(-z1)) / dzL) ! Units of m-1 + US%m_to_Z * ((1.0 - exp(-z1)) / dz(i,k)) ! Units of m-1 else Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 @@ -1698,23 +1744,23 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) ! boundary layer turbulence. real, dimension(SZI_(G)) :: & - htot ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. + htot ! Running sum of the depth in the BBL [Z ~> m]. real, dimension(SZIB_(G)) :: & uhtot, & ! running integral of u in the BBL [Z L T-1 ~> m2 s-1] - ustar, & ! bottom boundary layer turbulence speed [Z T-1 ~> m s-1]. + ustar, & ! bottom boundary layer piston velocity [H T-1 ~> m s-1 or kg m-2 s-1]. u2_bbl ! square of the mean zonal velocity in the BBL [L2 T-2 ~> m2 s-2] real :: vhtot(SZI_(G)) ! running integral of v in the BBL [Z L T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJB_(G)) :: & - vstar, & ! ustar at at v-points [Z T-1 ~> m s-1]. + vstar, & ! ustar at at v-points [H T-1 ~> m s-1 or kg m-2 s-1]. v2_bbl ! square of average meridional velocity in BBL [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dz ! The vertical distance between interfaces around a layer [Z ~> m] - real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: I_cdrag_sqrt ! The inverse of the square root of the drag coefficient [nondim] - real :: hvel ! thickness at velocity points [Z ~> m]. + real :: cdrag_sqrt ! Square root of the drag coefficient [nondim] + real :: hvel ! thickness at velocity points [Z ~> m] logical :: domore, do_i(SZI_(G)) integer :: i, j, k, is, ie, js, je, nz @@ -1748,7 +1794,9 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) endif cdrag_sqrt = sqrt(CS%cdrag) - I_cdrag_sqrt = 0.0 ; if (cdrag_sqrt > 0.0) I_cdrag_sqrt = 1.0 / cdrag_sqrt + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) !$OMP parallel default(shared) private(do_i,vhtot,htot,domore,hvel,uhtot,ustar,u2_bbl) !$OMP do @@ -1761,7 +1809,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (allocated(visc%Kv_bbl_v)) then do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then do_i(i) = .true. - vstar(i,J) = GV%H_to_Z*visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) + vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) endif ; enddo endif !### What about terms from visc%Ray? @@ -1781,12 +1829,12 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) ! 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) + hvel = dz(i,j,k) else - hvel = GV%H_to_Z*h(i,j+1,k) + hvel = dz(i,j+1,k) endif else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + hvel = 0.5*(dz(i,j,k) + dz(i,j+1,k)) endif if ((htot(i) + hvel) >= visc%bbl_thick_v(i,J)) then @@ -1802,7 +1850,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (.not.domore) exit enddo do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (htot(i) > 0.0)) then - v2_bbl(i,J) = (vhtot(i)*vhtot(i))/(htot(i)*htot(i)) + v2_bbl(i,J) = (vhtot(i)*vhtot(i)) / (htot(i)*htot(i)) else v2_bbl(i,J) = 0.0 endif ; enddo @@ -1815,7 +1863,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (allocated(visc%bbl_thick_u)) then do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then do_i(I) = .true. - ustar(I) = GV%H_to_Z*visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) + ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) endif ; enddo endif @@ -1833,12 +1881,12 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) ! 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) + hvel = dz(i,j,k) else ! OBC_DIRECTION_W - hvel = GV%H_to_Z*h(i+1,j,k) + hvel = dz(i+1,j,k) endif else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + hvel = 0.5*(dz(i,j,k) + dz(i+1,j,k)) endif if ((htot(I) + hvel) >= visc%bbl_thick_u(I,j)) then @@ -1854,18 +1902,18 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (.not.domore) exit enddo do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (htot(i) > 0.0)) then - u2_bbl(I) = (uhtot(I)*uhtot(I))/(htot(I)*htot(I)) + u2_bbl(I) = (uhtot(I)*uhtot(I)) / (htot(I)*htot(I)) else u2_bbl(I) = 0.0 endif ; enddo do i=is,ie - visc%ustar_BBL(i,j) = GV%Z_to_H*sqrt(0.5*G%IareaT(i,j) * & + visc%ustar_BBL(i,j) = sqrt(0.5*G%IareaT(i,j) * & ((G%areaCu(I-1,j)*(ustar(I-1)*ustar(I-1)) + & G%areaCu(I,j)*(ustar(I)*ustar(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1)) + & G%areaCv(i,J)*(vstar(i,J)*vstar(i,J))) ) ) - visc%TKE_BBL(i,j) = GV%Z_to_H*US%L_to_Z**2 * & + visc%TKE_BBL(i,j) = US%L_to_Z**2 * & (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + & G%areaCu(I,j) * (ustar(I)*u2_bbl(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1)) + & @@ -1904,7 +1952,8 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) real :: a(SZK_(GV)), a_0(SZK_(GV)) ! nondimensional temporary variables [nondim] real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures [R L2 T-2 ~> Pa] real :: Rcv(SZI_(G),SZK_(GV)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] - real :: I_Drho ! temporary variable [R-1 ~> m3 kg-1] + real :: I_Drho ! The inverse of the coordinate density difference between + ! layers [R-1 ~> m3 kg-1] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, k3, is, ie, nz, kmb @@ -1912,9 +1961,15 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) do k=2,nz-1 if (GV%g_prime(k+1) /= 0.0) then - do i=is,ie - ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) - enddo + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + do i=is,ie + ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) + enddo + else ! Use a mathematically equivalent form that avoids any dependency on RHO_0. + do i=is,ie + ds_dsp1(i,k) = (GV%Rlay(k) - GV%Rlay(k-1)) / (GV%Rlay(k+1) - GV%Rlay(k)) + enddo + endif else do i=is,ie ds_dsp1(i,k) = 1. @@ -1937,7 +1992,11 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) ! interfaces above and below the buffer layer and the next denser layer. k = kb(i) - I_Drho = g_R0 / GV%g_prime(k+1) + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + I_Drho = g_R0 / GV%g_prime(k+1) + else + I_Drho = 1.0 / (GV%Rlay(k+1) - GV%Rlay(k)) + endif ! The indexing convention for a is appropriate for the interfaces. do k3=1,kmb a(k3+1) = (GV%Rlay(k) - Rcv(i,k3)) * I_Drho @@ -2005,7 +2064,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ !! surface boundary layer. ! Local variables - real :: decay_length ! The maximum decay scale for the BBL diffusion [Z ~> m] + real :: decay_length ! The maximum decay scale for the BBL diffusion [H ~> m or kg m-2] logical :: ML_use_omega integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. @@ -2097,7 +2156,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "length scale.", default=.false.) if (CS%ML_radiation) then ! This give a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + GV%H_subroundoff*GV%H_to_Z) + CS%ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + GV%dZ_subroundoff) call get_param(param_file, mdl, "ML_RAD_EFOLD_COEFF", CS%ML_rad_efold_coeff, & "A coefficient that is used to scale the penetration "//& @@ -2161,7 +2220,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The maximum decay scale for the BBL diffusion, or 0 to allow the mixing "//& "to penetrate as far as stratification and rotation permit. The default "//& "for now is 200 m. This is only used if BOTTOMDRAGLAW is true.", & - units="m", default=200.0, scale=US%m_to_Z) + units="m", default=200.0, scale=GV%m_to_H) CS%IMax_decay = 0.0 if (decay_length > 0.0) CS%IMax_decay = 1.0/decay_length From 828a1789833e688087e544d408d516bc15ae088e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Aug 2023 03:05:08 -0400 Subject: [PATCH 057/146] *Non-Boussinesq refactoring of entrain_diffusive This commit refactors entrainment_diffusive to avoid any dependencies on the Boussinesq reference density when in non-Boussinesq mode, including using calculate_specific_vol_derivs for one diagnostic when non-Boussinesq. This commit includes making the formerly optional arguments kb_out, Kd_Lay and Kd_int to entrainment_diffusive non-optional, as they have been used in all calls to this routine for many years. Layer target density differences are now used in place of g_prime in entrainment_diffusive in mathematically equivalent expressions for the density difference ratios when non-Boussinesq. The non-Boussinesq upper layer buoyancy flux with entrainment_diffusive was revised to avoid using the Boussinesq reference density when the model is in layered mode but there is no equation of state or bulk mixed layer in use. The units of 3 internal variables were changed and there are 3 new internal variables as a part of these changes, and 4 thickness rescaling factors were eliminated. A default private setting is used to simplify a block of OMP directives. All answers are bitwise identical in Boussinesq mode, but they can change for some non-Boussinesq configurations, and three previously optional arguments have been made mandatory. --- .../vertical/MOM_entrain_diffusive.F90 | 182 ++++++++++-------- 1 file changed, 105 insertions(+), 77 deletions(-) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index c30f5c2c3f..de13322652 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -5,14 +5,15 @@ module MOM_entrain_diffusive use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_specific_vol_derivs, EOS_domain use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +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 implicit none ; private @@ -73,14 +74,13 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & intent(out) :: eb !< The amount of fluid entrained from the layer !! below within this time step [H ~> m or kg m-2]. integer, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: kb_out !< The index of the lightest layer denser than + intent(inout) :: kb_out !< The index of the lightest layer denser than !! the buffer layer. - ! At least one of the two following arguments must be present. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers + intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces + intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This subroutine calculates ea and eb, the rates at which a layer entrains @@ -112,7 +112,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real, allocatable, dimension(:,:,:) :: & Kd_eff, & ! The effective diffusivity that actually applies to each ! layer after the effects of boundary conditions are - ! considered [Z2 T-1 ~> m2 s-1]. + ! considered [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. diff_work ! The work actually done by diffusion across each ! interface [R Z3 T-3 ~> W m-2]. Sum vertically for the total work. @@ -174,16 +174,20 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & grats ! 2*(2 + ds_k+1 / ds_k + ds_k / ds_k+1) = ! 4*ds_Lay*(1/ds_k + 1/ds_k+1). [nondim] - real :: dRHo ! The change in locally referenced potential density between - ! the layers above and below an interface [R ~> kg m-3]. + real :: dRho ! The change in locally referenced potential density between + ! the layers above and below an interface [R ~> kg m-3] + real :: dSpV ! The change in locally referenced specific volume between + ! the layers above and below an interface [R-1 ~> m3 kg-1] real :: g_2dt ! 0.5 * G_Earth / dt, times unit conversion factors - ! [Z3 H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. + ! [Z3 H-2 T-3 or R2 Z3 H-2 T-3 ~> m s-3]. real, dimension(SZI_(G)) :: & pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. T_eos, S_eos, & ! The potential temperature and salinity at which to ! evaluate dRho_dT and dRho_dS [C ~> degC] and [S ~> ppt]. - dRho_dT, dRho_dS ! The partial derivatives of potential density with temperature and - ! salinity, [R C-1 ~> kg m-3 degC-1] and [R S-1 ~> kg m-3 ppt-1]. + dRho_dT, & ! The partial derivative of potential density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! The partial derivative of potential density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real :: tolerance ! The tolerance within which E must be converged [H ~> m or kg m-2]. real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. @@ -199,7 +203,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real :: ea_cor ! The corrective adjustment to eakb [H ~> m or kg m-2]. real :: h1 ! The layer thickness after entrainment through the ! interface below is taken into account [H ~> m or kg m-2]. - real :: Idt ! The inverse of the time step [T-1 ~> s-1]. + real :: Idt ! The inverse of the time step [Z H-1 T-1 ~> s-1 or m3 kg-1 s-1]. logical :: do_any logical :: do_entrain_eakb ! True if buffer layer is entrained @@ -217,9 +221,6 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & if (.not. CS%initialized) call MOM_error(FATAL, & "MOM_entrain_diffusive: Module must be initialized before it is used.") - if (.not.(present(Kd_Lay) .or. present(Kd_int))) call MOM_error(FATAL, & - "MOM_entrain_diffusive: Either Kd_Lay or Kd_int must be present in call.") - if ((.not.CS%bulkmixedlayer .and. .not.associated(fluxes%buoy)) .and. & (associated(fluxes%lprec) .or. associated(fluxes%evap) .or. & associated(fluxes%sens) .or. associated(fluxes%sw))) then @@ -254,42 +255,33 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif EOSdom(:) = EOS_domain(G%HI) - !$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & - !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & - !$OMP ea,eb,Kd_int,Kd_eff,EOSdom,diff_work,g_2dt, kb_out) & - !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) & - !$OMP private(dtKd,dtKd_int,do_i,Ent_bl,dtKd_kb,h_bl, & - !$OMP I2p2dsp1_ds,grats,htot,max_eakb,I_dSkbp1, & - !$OMP zeros,maxF_kb,maxF,ea_kbp1,eakb,Sref, & - !$OMP maxF_correct,do_any,do_entrain_eakb, & - !$OMP err_min_eakb0,err_max_eakb0,eakb_maxF, & - !$OMP min_eakb,err_eakb0,F,minF,hm,fk,F_kb_maxent,& - !$OMP F_kb,is1,ie1,kb_min_act,dFdfm_kb,b1,dFdfm, & - !$OMP Fprev,fm,fr,c1,reiterate,eb_kmb,did_i, & - !$OMP h_avail,h_guess,dS_kb,Rcv,F_cor,dS_kb_eff, & - !$OMP Rho_cor,ea_cor,h1,Idt,Kd_here,pressure, & - !$OMP T_eos,S_eos,dRho_dT,dRho_dS,dRho,dS_anom_lim) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & + !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & + !$OMP ea,eb,Kd_int,Kd_eff,EOSdom,diff_work,g_2dt, kb_out) & + !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) do j=js,je do i=is,ie ; kb(i) = 1 ; enddo - if (present(Kd_Lay)) then + if (allocated(tv%SpV_avg)) then do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H * (dt * Kd_lay(i,j,k)) + dtKd(i,k) = GV%RZ_to_H * (dt * Kd_lay(i,j,k)) / tv%SpV_avg(i,j,k) enddo ; enddo - if (present(Kd_int)) then - do K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) - enddo ; enddo - else - do K=2,nz ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H * (0.5 * dt * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k))) - enddo ; enddo - endif - else ! Kd_int must be present, or there already would have been an error. + do i=is,ie + dtKd_int(i,1) = GV%RZ_to_H * (dt * Kd_int(i,j,1)) / tv%SpV_avg(i,j,1) + dtKd_int(i,nz+1) = GV%RZ_to_H * (dt * Kd_int(i,j,nz+1)) / tv%SpV_avg(i,j,nz) + enddo + ! Use the mass-weighted average specific volume to translate thicknesses to verti distances. + do K=2,nz ; do i=is,ie + dtKd_int(i,K) = GV%RZ_to_H * (dt * Kd_int(i,j,K)) * & + ( (h(i,j,k-1) + h(i,j,k) + 2.0*h_neglect) / & + ((h(i,j,k-1)+h_neglect) * tv%SpV_avg(i,j,k-1) + & + (h(i,j,k)+h_neglect) * tv%SpV_avg(i,j,k)) ) + enddo ; enddo + else do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H * (0.5 * dt * (Kd_int(i,j,K)+Kd_int(i,j,K+1))) + dtKd(i,k) = GV%Z_to_H * (dt * Kd_lay(i,j,k)) enddo ; enddo - dO K=1,nz+1 ; do i=is,ie + do K=1,nz+1 ; do i=is,ie dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) enddo ; enddo endif @@ -298,9 +290,15 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & do i=is,ie ; ds_dsp1(i,nz) = 0.0 ; enddo do i=is,ie ; dsp1_ds(i,nz) = 0.0 ; enddo - do k=2,nz-1 ; do i=is,ie - ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) - enddo ; enddo + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + do k=2,nz-1 ; do i=is,ie + ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) + enddo ; enddo + else ! Use a mathematically equivalent form that avoids any dependency on RHO_0. + do k=2,nz-1 ; do i=is,ie + ds_dsp1(i,k) = (GV%Rlay(k) - GV%Rlay(k-1)) / (GV%Rlay(k+1) - GV%Rlay(k)) + enddo ; enddo + endif if (CS%bulkmixedlayer) then ! This subroutine determines the averaged entrainment across each @@ -393,9 +391,16 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & maxF(i,1) = 0.0 htot(i) = h(i,j,1) - Angstrom enddo - if (associated(fluxes%buoy)) then ; do i=is,ie - maxF(i,1) = GV%Z_to_H * (dt*fluxes%buoy(i,j)) / GV%g_prime(2) - enddo ; endif + if (associated(fluxes%buoy) .and. GV%Boussinesq) then + do i=is,ie + maxF(i,1) = GV%Z_to_H * (dt*fluxes%buoy(i,j)) / GV%g_prime(2) + enddo + elseif (associated(fluxes%buoy)) then + do i=is,ie + maxF(i,1) = (GV%RZ_to_H * 0.5*(GV%Rlay(1) + GV%Rlay(2)) * (dt*fluxes%buoy(i,j))) / & + GV%g_prime(2) + enddo + endif endif ! The following code calculates the maximum flux, maxF, for the interior @@ -819,7 +824,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif ! associated(tv%eqn_of_state)) if (CS%id_Kd > 0) then - Idt = GV%H_to_Z**2 / dt + Idt = (GV%H_to_m*US%m_to_Z) / dt do k=2,nz-1 ; do i=is,ie if (k 0) then - g_2dt = 0.5 * GV%H_to_Z**2*US%L_to_Z**2 * (GV%g_Earth / dt) + if (GV%Boussinesq .or. .not.associated(tv%eqn_of_state)) then + g_2dt = 0.5 * GV%H_to_Z**2 * US%L_to_Z**2 * (GV%g_Earth / dt) + else + g_2dt = 0.5 * GV%H_to_RZ**2 * US%L_to_Z**2 * (GV%g_Earth / dt) + endif do i=is,ie ; diff_work(i,j,1) = 0.0 ; diff_work(i,j,nz+1) = 0.0 ; enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then @@ -854,23 +863,44 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & S_eos(i) = 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) endif enddo - call calculate_density_derivs(T_EOS, S_EOS, pressure, dRho_dT, dRho_dS, & - tv%eqn_of_state, EOSdom) - do i=is,ie - if ((k>kmb) .and. (kkmb) .and. (kkmb) .and. (k Date: Fri, 30 Jun 2023 17:51:58 -0400 Subject: [PATCH 058/146] +Add RESTORE_FLUX_RHO and TKE_TIDAL_RHO Added the new runtime parameters RESTORE_FLUX_RHO and TKE_TIDAL_RHO to specify the densities that are used to convert the piston velocities into restoring heat or salt fluxes and to translate tidal velocities into tidal TKE input. Their defaults are set to RHO_0 to reproduce previous answers. Also added tau_mag arguments to 2 calls to allocate_forcing_type() and 4 calls to allocate_mech_forcing() in the FMS_cap and solo_driver code. There are new rho_restore elements in the FMS and solo_driver versions of surface_forcing_CS and in MESO_surface_forcing_CS and user_surface_forcing_CS. By default, all answers are bitwise identical, but there are new entries in some MOM_parameter_doc files. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 32 +++++++++++----- .../solo_driver/MESO_surface_forcing.F90 | 16 +++++--- .../solo_driver/MOM_surface_forcing.F90 | 38 +++++++++++-------- .../solo_driver/user_surface_forcing.F90 | 18 ++++++--- 4 files changed, 70 insertions(+), 34 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index a8398c3cc8..713f04dc18 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -112,8 +112,10 @@ module MOM_surface_forcing_gfdl !! salinity to a specified value. logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea !! surface temperature to a specified value. - real :: Flux_const_salt !< Piston velocity for surface salt restoring [Z T-1 ~> m s-1] - real :: Flux_const_temp !< Piston velocity for surface temp restoring [Z T-1 ~> m s-1] + real :: Flux_const_salt !< Piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: Flux_const_temp !< Piston velocity for surface temperature restoring [Z T-1 ~> m s-1] + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] logical :: trestore_SPEAR_ECDA !< If true, modify restoring data wrt local SSS real :: SPEAR_dTf_dS !< The derivative of the freezing temperature with !! salinity [C S-1 ~> degC ppt-1]. @@ -268,7 +270,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 kg_m2_s_conversion = US%kg_m2s_to_RZ_T - if (CS%restore_temp) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%restore_temp) rhoXcp = CS%rho_restore * fluxes%C_p open_ocn_mask(:,:) = 1.0 fluxes%vPrecGlobalAdj = 0.0 fluxes%vPrecGlobalScl = 0.0 @@ -281,7 +283,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., press=.true., & - fix_accum_bug=CS%fix_ustar_gustless_bug) + fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -363,7 +365,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const_salt)* & + fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const_salt)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) * delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then @@ -386,7 +388,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const_salt) * & + (CS%rho_restore*CS%Flux_const_salt) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -717,7 +719,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! mechanical forcing type has been used. if (.not.forces%initialized) then call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true.) + press=.true., tau_mag=.true.) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) @@ -1276,6 +1278,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. real :: Flux_const_dflt ! A default piston velocity for restoring surface properties [m day-1] + real :: rho_TKE_tidal ! The constant bottom density used to translate tidal amplitudes into the + ! tidal bottom TKE input used with INT_TIDE_DISSIPATION [R ~> kg m-3] logical :: new_sim ! False if this simulation was started from a restart file ! or other equivalent files. logical :: iceberg_flux_diags ! If true, diagnostics of fluxes from icebergs are available. @@ -1501,6 +1505,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "The derivative of the freezing temperature with salinity.", & units="deg C PSU-1", default=-0.054, scale=US%degC_to_C*US%S_to_ppt, & do_not_log=.not.CS%trestore_SPEAR_ECDA) + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=.not.(CS%restore_temp.or.CS%restore_salt)) ! Optionally read tidal amplitude from input file [Z T-1 ~> m s-1] on model grid. ! Otherwise use default tidal amplitude for bottom frictionally-generated @@ -1525,6 +1534,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) endif + call get_param(param_file, mdl, "TKE_TIDAL_RHO", rho_TKE_tidal, & + "The constant bottom density used to translate tidal amplitudes into the tidal "//& + "bottom TKE input used with INT_TIDE_DISSIPATION.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=.not.(CS%read_TIDEAMP.or.(CS%utide>0.0))) call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) @@ -1537,13 +1551,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) rescale=US%m_to_Z*US%T_to_s) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*rho_TKE_tidal*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else do j=jsd,jed; do i=isd,ied utide = CS%utide - CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = rho_TKE_tidal*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 index a3007326b7..f1f3daa52e 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -9,7 +9,7 @@ module MESO_surface_forcing use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_forcing_type, only : allocate_forcing_type use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_time_manager, only : time_type, operator(+), operator(/) @@ -30,6 +30,8 @@ module MESO_surface_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 :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: gust_const !< A constant unresolved background gustiness !! that contributes to ustar [R L Z T-2 ~> Pa] real, dimension(:,:), pointer :: & @@ -166,14 +168,14 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! call MOM_error(FATAL, "MESO_buoyancy_surface_forcing: " // & ! "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (CS%Rho0 * CS%Flux_const) * & + fluxes%vprec(i,j) = - (CS%rho_restore * CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -188,7 +190,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [R ~> kg m-3] that is being restored toward. @@ -272,7 +274,11 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) "variable NET_SOL.", fail_if_missing=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") CS%inputdir = slasher(CS%inputdir) - + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0).or.(.not.CS%restorebuoy)) endif end subroutine MESO_surface_forcing_init diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 859bfd81c8..8d46a80cae 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -79,9 +79,11 @@ module MOM_surface_forcing 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 :: Flux_const_T !< piston velocity for surface temperature restoring [Z T-1 ~> m s-1] - real :: Flux_const_S !< piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: Flux_const = 0.0 !< piston velocity for surface restoring [Z T-1 ~> m s-1] + real :: Flux_const_T = 0.0 !< piston velocity for surface temperature restoring [Z T-1 ~> m s-1] + real :: Flux_const_S = 0.0 !< piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" @@ -250,9 +252,9 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US if (CS%first_call_set_forcing) then ! Allocate memory for the mechanical and thermodynamic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) - call allocate_forcing_type(G, fluxes, ustar=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) + call allocate_forcing_type(G, fluxes, ustar=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.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.) @@ -837,7 +839,7 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) call callTree_enter("wind_forcing_by_data_override, MOM_surface_forcing.F90") if (.not.CS%dataOverrideIsInitialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) call data_override_init(G%Domain) CS%dataOverrideIsInitialized = .True. endif @@ -953,7 +955,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%use_temperature) rhoXcp = CS%rho_restore * fluxes%C_p ! Read the buoyancy forcing file call get_time(day, seconds, days) @@ -1152,7 +1154,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1164,7 +1166,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const / CS%Rho0) + (CS%G_Earth * CS%Flux_const / CS%rho_restore) else fluxes%buoy(i,j) = 0.0 endif @@ -1220,7 +1222,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%use_temperature) rhoXcp = CS%rho_restore * fluxes%C_p if (.not.CS%dataOverrideIsInitialized) then call data_override_init(G%Domain) @@ -1258,7 +1260,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1270,7 +1272,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const / CS%Rho0) + (CS%G_Earth * CS%Flux_const / CS%rho_restore) else fluxes%buoy(i,j) = 0.0 endif @@ -1457,8 +1459,8 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & + ((T_Restore - sfc_state%SST(i,j)) * ((CS%rho_restore * fluxes%C_p) * CS%Flux_const)) + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else @@ -1472,7 +1474,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) !do j=js,je ; do i=is,ie ! if (G%mask2dT(i,j) > 0.0) then ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * CS%Flux_const / CS%Rho0) + ! (CS%G_Earth * CS%Flux_const / CS%rho_restore) ! else ! fluxes%buoy(i,j) = 0.0 ! endif @@ -1874,6 +1876,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "at the southern end of the domain toward which to "//& "to restore.", units="PSU", default=35.0, scale=US%ppt_to_S) endif + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(((CS%Flux_const==0.0).and.(CS%Flux_const_T==0.0).and.(CS%Flux_const_S==0.0))& + .or.(.not.CS%restorebuoy))) endif call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 index d7d3b89a8a..7d4ea94603 100644 --- a/config_src/drivers/solo_driver/user_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/user_surface_forcing.F90 @@ -35,6 +35,8 @@ module user_surface_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 :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: gust_const !< A constant unresolved background gustiness !! that contributes to ustar [R L Z T-2 ~> Pa]. @@ -69,7 +71,7 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) ! Set the surface wind stresses, in units of [R L Z T-2 ~> Pa]. A positive taux ! accelerates the ocean to the (pseudo-)east. @@ -91,7 +93,8 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gust_const + & sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(forces%tau_mag(i,j) * (US%L_to_Z/CS%Rho0)) + if (associated(forces%ustar)) & + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(forces%tau_mag(i,j) * (US%L_to_Z/CS%Rho0)) enddo ; enddo ; endif end subroutine USER_wind_forcing @@ -200,7 +203,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in [C ~> degC]) and ! salinity (in [S ~> ppt]) that are being restored toward. @@ -209,7 +212,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) 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)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else @@ -219,7 +222,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [R ~> kg m-3] that is being restored toward. @@ -284,6 +287,11 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & default=0.0, units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T)) endif + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0).or.(.not.CS%restorebuoy)) end subroutine USER_surface_forcing_init From cf6ac00bb38d0df8328524c9f30a7338354cf05f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 17:53:41 -0400 Subject: [PATCH 059/146] Add tau_mag to allocate_forcing_type calls Add tau_mag argument to calls to allocate_forcing_type() in initialize_ice_shelf_fluxes and the mct_cap and noupc_cap versions of convert_IOB_to_fluxes and to calls to allocate_mech_forcing() in initialize_ice_shelf_forces and the mct_cap and noupc_cap versions of convert_IOB_to_forces. All answers are bitwise identical. --- config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 | 4 ++-- config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 | 4 ++-- src/ice_shelf/MOM_ice_shelf.F90 | 7 ++++--- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index ec5dab57a7..a5c2db6974 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -276,7 +276,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & - press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) + press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -649,7 +649,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 0d2a73aa64..aee95ddd91 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -308,7 +308,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, & - cfc=CS%use_CFC, hevap=CS%enthalpy_cpl) + cfc=CS%use_CFC, hevap=CS%enthalpy_cpl, tau_mag=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -716,7 +716,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d0faeb3aae..f5a85da95a 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1869,10 +1869,11 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) ! when SHELF_THERMO = True. These fluxes are necessary if one wants to ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & - press=.true., water=CS%isthermo, heat=CS%isthermo, shelf_sfc_accumulation = CS%active_shelf_dynamics) + press=.true., water=CS%isthermo, heat=CS%isthermo, shelf_sfc_accumulation=CS%active_shelf_dynamics, & + tau_mag=.true.) else call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") - call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., press=.true.) + call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) endif if (CS%rotate_index) then allocate(fluxes) @@ -1903,7 +1904,7 @@ subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) type(mech_forcing), pointer :: forces => NULL() call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating forces.") - call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true.) + call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) if (CS%rotate_index) then allocate(forces) call allocate_mech_forcing(forces_in, CS%Grid, forces) From 994ce9e914425db7984067f7e17cc133e8a4086e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 17:50:46 -0400 Subject: [PATCH 060/146] +Set tau_mag in idealized_hurricane_wind_forcing Calculate forces%tau_mag in idealized_hurricane_wind_forcing() and SCM_idealized_hurricane_wind_forcing(), and call allocate_mech_forcing with the new tau_mag argument so that this array is sure to be allocated. All answers are bitwise identical in existing test cases, but this step was necessary for this code to work in fully non-Boussinesq configurations. --- src/user/Idealized_Hurricane.F90 | 40 +++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index ad930911ca..5dd8084fbd 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -22,7 +22,7 @@ module Idealized_hurricane use MOM_error_handler, only : MOM_error, FATAL use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_forcing_type, only : allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_safe_alloc, only : safe_alloc_ptr use MOM_time_manager, only : time_type, operator(+), operator(/), time_type_to_real @@ -251,7 +251,7 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) 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.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) if (CS%relative_tau) then REL_TAU_FAC = 1. @@ -325,16 +325,20 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) enddo !> Get Ustar - 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%gustiness/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 + 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%gustiness/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 + + !> Get tau_mag [R L Z T-2 ~> Pa] + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gustiness + & + 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))) + enddo ; enddo ; endif - return end subroutine idealized_hurricane_wind_forcing !> Calculate the wind speed at a location as a function of time. @@ -522,7 +526,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) pie = 4.0*atan(1.0) ; Deg2Rad = pie/180. !/ BR ! Implementing Holland (1980) parameteric wind profile @@ -667,13 +671,21 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C endif forces%tauy(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCv(I,j) * Cd*dU10*dV enddo ; enddo + ! Set the surface friction velocity [Z T-1 ~> m s-1]. ustar is always positive. - do j=js,je ; do i=is,ie + 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%gustiness/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 + enddo ; enddo ; endif + + !> Set magnitude of the wind stress [R L Z T-2 ~> Pa] + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gustiness + & + 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))) + enddo ; enddo ; endif end subroutine SCM_idealized_hurricane_wind_forcing From d1077375d5109384f300b8e35789ab130cf061d2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 5 Jul 2023 17:35:18 -0400 Subject: [PATCH 061/146] +Use RESTORE_FLUX_RHO in dumbbell & SCM_CVMix_tests Use RESTORE_FLUX_RHO in SCM_CVMix_tests and dumbbell_surface_forcing to specify the density that are used to convert the piston velocities into restoring heat or salt fluxes. As with other analogous changes, the default is set to RHO_0 to reproduce previous answers. Also set forces%tau_mag in SCM_CVMix_tests_wind_forcing if it is associated. There is a new rho_restore element in the control structures for the SCM_CVMix_tests two module, while the units of an element in the dumbbell_surface_forcing module are changed. By default, all existing answers are bitwise identical, but there are new entries in some MOM_parameter_doc files. --- src/user/SCM_CVMix_tests.F90 | 18 ++++++++++++++---- src/user/dumbbell_surface_forcing.F90 | 19 +++++++++++++------ 2 files changed, 27 insertions(+), 10 deletions(-) diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 7b1b4b3946..104a2b0312 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -42,6 +42,8 @@ module SCM_CVMix_tests real :: surf_evap !< (Constant) Evaporation rate [Z T-1 ~> m s-1] real :: Max_sw !< maximum of diurnal sw radiation [C Z T-1 ~> degC m s-1] real :: Rho0 !< reference density [R ~> kg m-3] + real :: rho_restore !< The density that is used to convert piston velocities + !! into salt or heat fluxes [R ~> kg m-3] end type ! This include declares and sets the variable "version". @@ -184,6 +186,9 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) "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, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat fluxes.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) end subroutine SCM_CVMix_tests_surface_forcing_init @@ -214,7 +219,11 @@ subroutine SCM_CVMix_tests_wind_forcing(sfc_state, forces, day, G, US, CS) mag_tau = sqrt(CS%tau_x*CS%tau_x + CS%tau_y*CS%tau_y) if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / (CS%Rho0) ) + forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / CS%Rho0 ) + enddo ; enddo ; endif + + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = mag_tau enddo ; enddo ; endif end subroutine SCM_CVMix_tests_wind_forcing @@ -246,7 +255,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) ! therefore must convert to [Q R Z T-1 ~> W m-2] by multiplying ! by Rho0*Cp do J=Jsq,Jeq ; do i=is,ie - fluxes%sens(i,J) = CS%surf_HF * CS%Rho0 * fluxes%C_p + fluxes%sens(i,J) = CS%surf_HF * CS%rho_restore * fluxes%C_p enddo ; enddo endif @@ -255,7 +264,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) ! Note CVMix test inputs give evaporation in [Z T-1 ~> m s-1] ! This therefore must be converted to mass flux in [R Z T-1 ~> kg m-2 s-1] ! by multiplying by density and some unit conversion factors. - fluxes%evap(i,J) = CS%surf_evap * CS%Rho0 + fluxes%evap(i,J) = CS%surf_evap * CS%rho_restore enddo ; enddo endif @@ -264,7 +273,8 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) ! Note CVMix test inputs give max sw rad in [Z C T-1 ~> m degC s-1] ! therefore must convert to [Q R Z T-1 ~> W m-2] by multiplying by Rho0*Cp ! Note diurnal cycle peaks at Noon. - fluxes%sw(i,J) = CS%Max_sw * max(0.0, cos(2*PI*(time_type_to_real(DAY)/86400.0 - 0.5))) * CS%RHO0 * fluxes%C_p + fluxes%sw(i,J) = CS%Max_sw * max(0.0, cos(2*PI*(time_type_to_real(DAY)/86400.0 - 0.5))) * & + CS%rho_restore * fluxes%C_p enddo ; enddo endif diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index ca383ba1f1..6f6e4da439 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -25,9 +25,8 @@ module dumbbell_surface_forcing type, public :: dumbbell_surface_forcing_CS ; private 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 :: Flux_const !< The restoring rate at the surface [R Z T-1 ~> kg m-2 s-1]. ! real :: gust_const !< A constant unresolved background gustiness ! !! that contributes to ustar [R L Z T-2 ~> Pa]. real :: slp_amplitude !< The amplitude of pressure loading [R L2 T-2 ~> Pa] applied @@ -114,7 +113,7 @@ subroutine dumbbell_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature .and. CS%restorebuoy) then do j=js,je ; do i=is,ie if (CS%forcing_mask(i,j)>0.) then - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * CS%Flux_const) * & ((CS%S_restore(i,j) - sfc_state%SSS(i,j)) / (0.5 * (CS%S_restore(i,j) + sfc_state%SSS(i,j)))) endif @@ -181,6 +180,9 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) real :: S_surf ! Initial surface salinity [S ~> ppt] real :: S_range ! Range of the initial vertical distribution of salinity [S ~> ppt] real :: x ! Latitude normalized by the domain size [nondim] + real :: Rho0 ! The density used in the Boussinesq approximation [R ~> kg m-3] + real :: rho_restore ! The density that is used to convert piston velocities into salt + ! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] integer :: i, j logical :: dbrotate ! If true, rotate the domain. # include "version_variable.h" @@ -202,7 +204,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) 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, & + call get_param(param_file, mdl, "RHO_0", Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& @@ -233,8 +235,13 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) "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) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0)) + ! Convert FLUXCONST from m day-1 to m s-1 and Flux_const to [R Z T-1 ~> kg m-2 s-1] + CS%Flux_const = rho_restore * (CS%Flux_const / 86400.0) allocate(CS%forcing_mask(G%isd:G%ied, G%jsd:G%jed), source=0.0) From 5afb1222abf1f0bbffc12e80548f32f2646ae8f3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 25 Jul 2023 12:07:53 -0400 Subject: [PATCH 062/146] Resolve warning about S_REF units The units of S_REF were first registered in "PSU" and then later by benchmark in "ppt" which led to a WARNING. Although there is no uniformity to the units of S_REF throughout the user code (currently PSU, ppt, and 1e-3) are all used, benchmark is the only one that leads to a warning in the current suite and changing all to be consistent would 1) unnecessarily update the doc files, and 2) not be correct for all models. Bottom line, I'm punting on the best way to handle units of salinity. This commit resolves the only WARNING we currently get in the MOM6-examples suite. --- src/user/benchmark_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 333f53895e..ad75d83efa 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -142,7 +142,7 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e units="degC", default=29.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, & "The uniform salinities used to initialize the benchmark test case.", & - units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + units="PSU", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! This subroutine has no run-time parameters. From 4c224e704f9bae6bdc6741f677f4b5b902ec5b8a Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Mon, 21 Aug 2023 14:52:34 -0400 Subject: [PATCH 063/146] Bugfix in MLE for reproducible restarts with USE_BODNER23 = True - Update for missing halo update of field wpup_filtered in MOM_mixed_layer_restrat.F90 during initialization. - The missing halo update caused the model to diverge when running from restart files. - With the halo update the model now reproduces from restart files. --- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 5b7ec60dee..9cf79b07ce 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1584,6 +1584,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, ! If MLD_filtered is being used, we need to update halo regions after a restart if (allocated(CS%MLD_filtered)) call pass_var(CS%MLD_filtered, G%domain) if (allocated(CS%MLD_filtered_slow)) call pass_var(CS%MLD_filtered_slow, G%domain) + if (allocated(CS%wpup_filtered)) call pass_var(CS%wpup_filtered, G%domain) end function mixedlayer_restrat_init From 7e51f1d6d82e1ba6fbc90df3bde8bbe4607a2f15 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 26 Jul 2023 16:27:45 -0400 Subject: [PATCH 064/146] +*Non-Boussinesq form of mixedlayer_restrat Revised the code in MOM_mixed_layer_restrat.F90 to work internally with thickness-based units for the restratification timescale calculation and other internal calculations, which eliminates the dependence in this module on the value of the Boussinesq reference density in non-Boussinesq mode. Several other minor issues (which might not change any answers in production runs) were also fixed. The changes with this commit include: - When in non-Boussinesq mode, the mixed layer buoyancy gradients are determined from the average specific volume referenced to the surface pressure, rather than from the average potential density. - Use find_ustar to set the friction velocities in the appropriate units in the various mixed_layer_restrat routines. - A logical branch was added based on the correct mask for land or OBC points to avoid potentially ill-defined calculations of the magnitude of the Bodner parameterization streamfunction, some which were leading to NaNs. - Set a tiny but nonzero default value for MIN_WSTAR2 to avoid NaNs in some calculations of the streamfunction magnitude. - Within the function mu, the expression for dd was revised in a mathematically equivalent way to avoid any possibility of taking a fractional exponential power of a tiny negative number due to truncation errors, which was leading to NaNs in some cases while developing and debugging the other changes in this commit. This does not appear to change any answers in the existing test cases, perhaps because the mixed layer restratification "tail" is not being activated by setting TAIL_DH to be larger than 0. - The addition of code to both mixedlayer_restrat_Bodner and mixedlayer_restrat_OM4 to determine the mixed layer thickness from its vertical extent when in non-Boussinesq mode. This commit includes changes to the units of the Kv_restrat, ustar_min and wpup_filtered elements in the mixedlayer_restrat_CS type and the units of four arguments to the private function growth_time. CS%wpup_filtered also appears in the restart files generated with some mixed layer restratification settings, and it is rescaled to units of vertical distance or mass per unit area in the restart files depending on whether the model is Boussinesq. There are 17 new or renamed internal variables, while the units of 21 internal variables were changed. 19 rescaling factors were cancelled out or replaced. There are also comments where variable units were corrected or added. The rescaling of several chksum calls for thicknesses was modified to GV%H_to_mks to avoid any dependence on RHO_0 when non-Boussinesq. No public interfaces are changed. All answers are bitwise identical in Boussinesq mode (at least when TAIL_DH=0.), but solutions will change in non-Boussinesq mode when mixed layer restratification is enabled, including changes to the units of a variable in the restart files. --- .../lateral/MOM_mixed_layer_restrat.F90 | 532 ++++++++++++------ 1 file changed, 345 insertions(+), 187 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 9cf79b07ce..444ef8f064 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -19,7 +19,7 @@ module MOM_mixed_layer_restrat use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units -use MOM_EOS, only : calculate_density, EOS_domain +use MOM_EOS, only : calculate_density, calculate_spec_vol, EOS_domain implicit none ; private @@ -86,15 +86,17 @@ module MOM_mixed_layer_restrat type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. - logical :: use_stanley_ml !< If true, use the Stanley parameterization of SGS T variance - real :: ustar_min !< A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1] + logical :: use_Stanley_ML !< If true, use the Stanley parameterization of SGS T variance + real :: ustar_min !< A minimum value of ustar in thickness units to avoid numerical + !! problems [H T-1 ~> m s-1 or kg m-2 s-1] real :: Kv_restrat !< A viscosity that sets a floor on the momentum mixing rate - !! during restratification [Z2 T-1 ~> m2 s-1] + !! during restratification, rescaled into thickness-based + !! units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] real, dimension(:,:), allocatable :: & MLD_filtered, & !< Time-filtered MLD [H ~> m or kg m-2] MLD_filtered_slow, & !< Slower time-filtered MLD [H ~> m or kg m-2] - wpup_filtered !< Time-filtered vertical momentum flux [Z2 T-2 ~> m2 s-2] + wpup_filtered !< Time-filtered vertical momentum flux [H L T-2 ~> m2 s-2 or kg m-1 s-2] !>@{ !! Diagnostic identifier @@ -173,7 +175,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by the - !! PBL scheme [Z ~> m] (not H) + !! PBL scheme [Z ~> m] type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure @@ -184,27 +186,37 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & - U_star_2d, & ! The wind friction velocity, calculated using + U_star_2d, & ! The wind friction velocity in thickness-based units, calculated using ! the Boussinesq reference density or the time-evolving surface density - ! in non-Boussinesq mode [Z T-1 ~> m s-1] + ! in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] MLD_fast, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] htot_fast, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - Rml_av_fast, & ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] + Rml_av_fast, & ! Negative g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] MLD_slow, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] htot_slow, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - Rml_av_slow ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + Rml_av_slow ! Negative g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: rml_int_fast(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3] + real :: rml_int_slow(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int_fast(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: SpV_int_slow(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: H_mld(SZI_(G)) ! The thickness of water within the topmost MLD_in of height [H ~> m or kg m-2] + real :: MLD_rem(SZI_(G)) ! The vertical extent of the MLD_in that has not yet been accounted for [Z ~> m] real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] - real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] - real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: u_star ! surface friction velocity, interpolated to velocity points and recast into + ! thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1]. real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] - real :: dz_neglect ! A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux @@ -256,9 +268,12 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, if (.not. allocated(VarMix%Rd_dx_h) .and. CS%front_length > 0.) & call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "The resolution argument, Rd/dx, was not associated.") + if (CS%use_Stanley_ML .and. .not.GV%Boussinesq) call MOM_error(FATAL, & + "MOM_mixedlayer_restrat: The Stanley parameterization is not"//& + "available without the Boussinesq approximation.") ! Extract the friction velocity from the forcing type. - call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) if (CS%MLE_density_diff > 0.) then ! We need to calculate a mixed layer depth, MLD. !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA @@ -304,9 +319,30 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, enddo enddo ! j-loop elseif (CS%MLE_use_PBL_MLD) then - do j = js-1, je+1 ; do i = is-1, ie+1 - MLD_fast(i,j) = (CS%MLE_MLD_stretch * GV%Z_to_H) * MLD_in(i,j) - enddo ; enddo + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + do j = js-1, je+1 ; do i = is-1, ie+1 + MLD_fast(i,j) = CS%MLE_MLD_stretch * GV%Z_to_H * MLD_in(i,j) + enddo ; enddo + else ! The fully non-Boussinesq conversion between height in MLD_in and thickness. + do j=js-1,je+1 + do i=is-1,ie+1 ; MLD_rem(i) = MLD_in(i,j) ; H_mld(i) = 0.0 ; enddo + do k=1,nz + keep_going = .false. + do i=is-1,ie+1 ; if (MLD_rem(i) > 0.0) then + if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then + H_mld(i) = H_mld(i) + h(i,j,k) + MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + keep_going = .true. + else + H_mld(i) = H_mld(i) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) + MLD_rem(i) = 0.0 + endif + endif ; enddo + if (.not.keep_going) exit + enddo + do i=is-1,ie+1 ; MLD_fast(i,j) = CS%MLE_MLD_stretch * H_mld(i) ; enddo + enddo + endif else call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "No MLD to use for MLE parameterization.") @@ -315,7 +351,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! Apply time filter (to remove diurnal cycle) if (CS%MLE_MLD_decay_time>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(MLD_in, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, scale=US%Z_to_m) endif aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) @@ -332,8 +368,8 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! Apply slower time filter (to remove seasonal cycle) on already filtered MLD_fast if (CS%MLE_MLD_decay_time2>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered_slow,'mixed_layer_restrat: MLD_filtered_slow',G%HI,haloshift=1,scale=GV%H_to_m) - call hchksum(MLD_fast,'mixed_layer_restrat: MLD fast',G%HI,haloshift=1,scale=GV%H_to_m) + call hchksum(CS%MLD_filtered_slow, 'mixed_layer_restrat: MLD_filtered_slow', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD fast', G%HI, haloshift=1, scale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time2 / ( dt + CS%MLE_MLD_decay_time2 ) bFac = dt / ( dt + CS%MLE_MLD_decay_time2 ) @@ -353,9 +389,8 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, uDml(:) = 0.0 ; vDml(:) = 0.0 uDml_slow(:) = 0.0 ; vDml_slow(:) = 0.0 I4dt = 0.25 / dt - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff*GV%H_to_Z if (CS%front_length>0.) then res_upscale = .true. I_LFront = 1. / CS%front_length @@ -366,58 +401,106 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & - !$OMP line_is_empty, keep_going,res_scaling_fac, & + !$OMP SpV_ml,SpV_int_fast,SpV_int_slow,Rml_int_fast,Rml_int_slow, & + !$OMP line_is_empty,keep_going,res_scaling_fac, & !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & !$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) - !$OMP do - do j=js-1,je+1 - do i=is-1,ie+1 - htot_fast(i,j) = 0.0 ; Rml_av_fast(i,j) = 0.0 - htot_slow(i,j) = 0.0 ; Rml_av_slow(i,j) = 0.0 - enddo - keep_going = .true. - do k=1,nz + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP do + do j=js-1,je+1 do i=is-1,ie+1 - h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + htot_fast(i,j) = 0.0 ; Rml_int_fast(i) = 0.0 + htot_slow(i,j) = 0.0 ; Rml_int_slow(i) = 0.0 enddo - if (keep_going) then - if (CS%use_Stanley_ML) then - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & - rho_ml(:), tv%eqn_of_state, EOSdom) - else - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) - endif - line_is_empty = .true. + keep_going = .true. + do k=1,nz do i=is-1,ie+1 - if (htot_fast(i,j) < MLD_fast(i,j)) then - dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) - Rml_av_fast(i,j) = Rml_av_fast(i,j) + dh*rho_ml(i) - htot_fast(i,j) = htot_fast(i,j) + dh - line_is_empty = .false. - endif - if (htot_slow(i,j) < MLD_slow(i,j)) then - dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) - Rml_av_slow(i,j) = Rml_av_slow(i,j) + dh*rho_ml(i) - htot_slow(i,j) = htot_slow(i,j) + dh - line_is_empty = .false. - endif + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo - if (line_is_empty) keep_going=.false. - endif + if (keep_going) then + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + rho_ml(:), tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) + endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot_fast(i,j) < MLD_fast(i,j)) then + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + Rml_int_fast(i) = Rml_int_fast(i) + dh*rho_ml(i) + htot_fast(i,j) = htot_fast(i,j) + dh + line_is_empty = .false. + endif + if (htot_slow(i,j) < MLD_slow(i,j)) then + dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) + Rml_int_slow(i) = Rml_int_slow(i) + dh*rho_ml(i) + htot_slow(i,j) = htot_slow(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo + + do i=is-1,ie+1 + Rml_av_fast(i,j) = -(g_Rho0*Rml_int_fast(i)) / (htot_fast(i,j) + h_neglect) + Rml_av_slow(i,j) = -(g_Rho0*Rml_int_slow(i)) / (htot_slow(i,j) + h_neglect) + enddo enddo + else ! This is only used in non-Boussinesq mode. + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot_fast(i,j) = 0.0 ; SpV_int_fast(i) = 0.0 + htot_slow(i,j) = 0.0 ; SpV_int_slow(i) = 0.0 + enddo + keep_going = .true. + do k=1,nz + do i=is-1,ie+1 + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + if (keep_going) then + ! if (CS%use_Stanley_ML) then ! This is not implemented yet in the EoS code. + ! call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + ! rho_ml(:), tv%eqn_of_state, EOSdom) + ! else + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + ! endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot_fast(i,j) < MLD_fast(i,j)) then + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + SpV_int_fast(i) = SpV_int_fast(i) + dh*SpV_ml(i) + htot_fast(i,j) = htot_fast(i,j) + dh + line_is_empty = .false. + endif + if (htot_slow(i,j) < MLD_slow(i,j)) then + dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) + SpV_int_slow(i) = SpV_int_slow(i) + dh*SpV_ml(i) + htot_slow(i,j) = htot_slow(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo - do i=is-1,ie+1 - Rml_av_fast(i,j) = -(g_Rho0*Rml_av_fast(i,j)) / (htot_fast(i,j) + h_neglect) - Rml_av_slow(i,j) = -(g_Rho0*Rml_av_slow(i,j)) / (htot_slow(i,j) + h_neglect) + ! Convert the vertically integrated specific volume into a positive variable with units of density. + do i=is-1,ie+1 + Rml_av_fast(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int_fast(i)) / (htot_fast(i,j) + h_neglect) + Rml_av_slow(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int_slow(i)) / (htot_slow(i,j) + h_neglect) + enddo enddo - enddo + endif if (CS%debug) then - call hchksum(h,'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) - call hchksum(MLD_fast,'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(Rml_av_fast,'mixed_layer_restrat: rml', G%HI, haloshift=1, & - scale=US%m_to_Z*US%L_T_to_m_s**2) + call hchksum(h, 'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=GV%H_to_m*US%s_to_T) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(Rml_av_fast, 'mixed_layer_restrat: rml', G%HI, haloshift=1, & + scale=GV%m_to_H*US%L_T_to_m_s**2) endif ! TO DO: @@ -437,34 +520,34 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 - h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) * GV%H_to_Z + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef if (res_upscale) timescale = timescale * res_scaling_fac uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & - (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2) ! As above but using the slow filtered MLD - h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) * GV%H_to_Z + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef2 if (res_upscale) timescale = timescale * res_scaling_fac uDml_slow(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & - (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2) if (uDml(I) + uDml_slow(I) == 0.) then do k=1,nz ; uhml(I,j,k) = 0.0 ; enddo @@ -524,34 +607,34 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 - h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) * GV%H_to_Z + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef if (res_upscale) timescale = timescale * res_scaling_fac vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & - (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2) ! As above but using the slow filtered MLD - h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) * GV%H_to_Z + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef2 if (res_upscale) timescale = timescale * res_scaling_fac vDml_slow(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & - (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2) if (vDml(i) + vDml_slow(i) == 0.) then do k=1,nz ; vhml(i,J,k) = 0.0 ; enddo @@ -710,31 +793,40 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d real :: vol_dt_avail(SZI_(G),SZJ_(G),SZK_(GV)) ! The volume available for exchange out of each face of ! each layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G)) :: & - little_h, & ! "Little h" representing active mixing layer depth [Z ~> m] - big_H, & ! "Big H" representing the mixed layer depth [Z ~> m] + little_h, & ! "Little h" representing active mixing layer depth [H ~> m or kg m-2] + big_H, & ! "Big H" representing the mixed layer depth [H ~> m or kg m-2] htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - buoy_av, & ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - wpup ! Turbulent vertical momentum [ ????? ~> m2 s-2] + buoy_av, & ! g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + wpup ! Turbulent vertical momentum [L H T-2 ~> m2 s-2 or kg m-1 s-2] real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity, calculated using the Boussinesq ! reference density or the time-evolving surface density in non-Boussinesq ! mode [Z T-1 ~> m s-1] - real :: covTS(SZI_(G)) ! SGS TS covariance in Stanley param; currently 0 [degC ppt] - real :: varS(SZI_(G)) ! SGS S variance in Stanley param; currently 0 [ppt2] + real :: BLD_in_H(SZI_(G)) ! The thickness of the active boundary layer with the topmost BLD of + ! height [H ~> m or kg m-2] + real :: covTS(SZI_(G)) ! SGS TS covariance in Stanley param; currently 0 [C S ~> degC ppt] + real :: varS(SZI_(G)) ! SGS S variance in Stanley param; currently 0 [S2 ~> ppt2] real :: dmu(SZK_(GV)) ! Change in mu(z) across layer k [nondim] + real :: Rml_int(SZI_(G)) ! Potential density integrated through the mixed layer [R H ~> kg m-2 or kg2 m-5] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: H_mld(SZI_(G)) ! The thickness of water within the topmost BLD of height [H ~> m or kg m-2] + real :: MLD_rem(SZI_(G)) ! The vertical extent of the BLD that has not yet been accounted for [Z ~> m] real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] - real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] real :: w_star3 ! Cube of turbulent convective velocity [m3 s-3] real :: u_star3 ! Cube of surface fruction velocity [m3 s-3] - real :: r_wpup ! reciprocal of vertical momentum flux [Z-2 T2 ~> m-2 s2] + real :: r_wpup ! reciprocal of vertical momentum flux [T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] real :: grid_dsd ! combination of grid scales [L2 ~> m2] - real :: h_sml ! "Little h", the active mixing depth with diurnal cycle removed [Z ~> m] - real :: h_big ! "Big H", the mixed layer depth based on a time filtered "little h" [Z ~> m] - real :: grd_b ! The vertically average gradient of buoyancy [L Z-1 T-2 ~> s-2] + real :: h_sml ! "Little h", the active mixing depth with diurnal cycle removed [H ~> m or kg m-2] + real :: h_big ! "Big H", the mixed layer depth based on a time filtered "little h" [H ~> m or kg m-2] + real :: grd_b ! The vertically average gradient of buoyancy [L H-1 T-2 ~> s-2 or m-3 kg-1 s-2] real :: psi_mag ! Magnitude of stream function [L2 H T-1 ~> m3 s-1 or kg s-1] real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] @@ -754,7 +846,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB I4dt = 0.25 / dt - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff covTS(:) = 0.0 ! Might be in tv% in the future. Not implemented for the time being. @@ -775,24 +867,49 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) if (CS%debug) then - call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(BLD, 'mle_Bodner: BLD in', G%HI, haloshift=1, scale=US%Z_to_m) if (associated(bflux)) & call hchksum(bflux, 'mle_Bodner: bflux', G%HI, haloshift=1, scale=US%Z_to_m**2*US%s_to_T**3) call hchksum(U_star_2d, 'mle_Bodner: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) call hchksum(CS%MLD_filtered, 'mle_Bodner: MLD_filtered 1', & - G%HI, haloshift=1, scale=US%Z_to_m) + G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 1', & - G%HI, haloshift=1, scale=US%Z_to_m) + G%HI, haloshift=1, scale=GV%H_to_mks) endif ! Apply time filter to BLD (to remove diurnal cycle) to obtain "little h". ! "little h" is representative of the active mixing layer depth, used in B22 formula (eq 27). - do j = js-1, je+1 ; do i = is-1, ie+1 - little_h(i,j) = rmean2ts(BLD(i,j), CS%MLD_filtered(i,j), & - CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) - CS%MLD_filtered(i,j) = little_h(i,j) - enddo ; enddo + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + do j = js-1, je+1 ; do i = is-1, ie+1 + little_h(i,j) = rmean2ts(GV%Z_to_H*BLD(i,j), CS%MLD_filtered(i,j), & + CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) + CS%MLD_filtered(i,j) = little_h(i,j) + enddo ; enddo + else ! The fully non-Boussinesq conversion between height in BLD and thickness. + do j=js-1,je+1 + do i=is-1,ie+1 ; MLD_rem(i) = BLD(i,j) ; H_mld(i) = 0.0 ; enddo + do k=1,nz + keep_going = .false. + do i=is-1,ie+1 ; if (MLD_rem(i) > 0.0) then + if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then + H_mld(i) = H_mld(i) + h(i,j,k) + MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + keep_going = .true. + else + H_mld(i) = H_mld(i) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) + MLD_rem(i) = 0.0 + endif + endif ; enddo + if (.not.keep_going) exit + enddo + do i=is-1,ie+1 + little_h(i,j) = rmean2ts(H_mld(i), CS%MLD_filtered(i,j), & + CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) + CS%MLD_filtered(i,j) = little_h(i,j) + enddo + enddo + endif ! Calculate "big H", representative of the mixed layer depth, used in B22 formula (eq 27). do j = js-1, je+1 ; do i = is-1, ie+1 @@ -804,11 +921,11 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! Estimate w'u' at h-points do j = js-1, je+1 ; do i = is-1, ie+1 w_star3 = max(0., -bflux(i,j)) * BLD(i,j) & ! (this line in Z3 T-3 ~> m3 s-3) - * ( ( US%Z_to_m * US%s_to_T )**3 ) ! m3 s-3 + * ( ( US%Z_to_m * US%s_to_T )**3 ) ! [m3 T3 Z-3 s-3 ~> 1] u_star3 = ( US%Z_to_m * US%s_to_T * U_star_2d(i,j) )**3 ! m3 s-3 wpup(i,j) = max( CS%min_wstar2, & ! The max() avoids division by zero later ( CS%mstar * u_star3 + CS%nstar * w_star3 )**two_thirds ) & ! (this line m2 s-2) - * ( ( US%m_to_Z * US%T_to_s )**2 ) ! Z2 T-2 ~> m2 s-2 + * ( US%m_to_L * GV%m_to_H * US%T_to_s**2 ) ! [L H s2 m-2 T-2 ~> 1 or kg m-3] ! We filter w'u' with the same time scales used for "little h" wpup(i,j) = rmean2ts(wpup(i,j), CS%wpup_filtered(i,j), & CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) @@ -816,13 +933,13 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d enddo ; enddo if (CS%debug) then - call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, scale=US%Z_to_m) - call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(CS%MLD_filtered,'mle_Bodner: MLD_filtered 2', & - G%HI, haloshift=1, scale=US%Z_to_m) + G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 2', & - G%HI, haloshift=1, scale=US%Z_to_m) - call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, scale=(US%Z_to_m*US%s_to_T)**2) + G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, scale=US%L_to_m*GV%H_to_mks*US%s_to_T**2) endif ! Calculate the average density in the "mixed layer". @@ -834,11 +951,13 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d !$OMP default(shared) & !$OMP private(i, j, k, keep_going, line_is_empty, dh, & !$OMP grid_dsd, absf, h_sml, h_big, grd_b, r_wpup, psi_mag, IhTot, & - !$OMP sigint, muzb, muza, hAtVel) + !$OMP sigint, muzb, muza, hAtVel, Rml_int, SpV_int) + !$OMP do do j=js-1,je+1 + rho_ml(:) = 0.0 ; SpV_ml(:) = 0.0 do i=is-1,ie+1 - htot(i,j) = 0.0 ; buoy_av(i,j) = 0.0 + htot(i,j) = 0.0 ; Rml_int(i) = 0.0 ; SpV_int(i) = 0.0 enddo keep_going = .true. do k=1,nz @@ -846,17 +965,22 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d vol_dt_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo if (keep_going) then - if (CS%use_Stanley_ML) then - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & - rho_ml(:), tv%eqn_of_state, EOSdom) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + rho_ml, tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml, tv%eqn_of_state, EOSdom) + endif else - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) endif line_is_empty = .true. do i=is-1,ie+1 - if (htot(i,j) < big_H(i,j)*GV%Z_to_H) then - dh = min( h(i,j,k), big_H(i,j)*GV%Z_to_H - htot(i,j) ) - buoy_av(i,j) = buoy_av(i,j) + dh*rho_ml(i) ! Here, buoy_av has units of R H ~> kg m-2 + if (htot(i,j) < big_H(i,j)) then + dh = min( h(i,j,k), big_H(i,j) - htot(i,j) ) + Rml_int(i) = Rml_int(i) + dh*rho_ml(i) ! Rml_int has units of [R H ~> kg m-2] + SpV_int(i) = SpV_int(i) + dh*SpV_ml(i) ! SpV_int has units of [H R-1 ~> m4 kg-1 or m] htot(i,j) = htot(i,j) + dh line_is_empty = .false. endif @@ -865,18 +989,24 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d endif enddo - do i=is-1,ie+1 - ! Hereafter, buoy_av has units (L2 Z-1 T-2 R-1) * (R H) * H-1 = L2 Z-1 T-2 ~> m s-2 - buoy_av(i,j) = -( g_Rho0 * buoy_av(i,j) ) / (htot(i,j) + h_neglect) - enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is-1,ie+1 + ! Buoy_av has units (L2 H-1 T-2 R-1) * (R H) * H-1 = L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2 + buoy_av(i,j) = -( g_Rho0 * Rml_int(i) ) / (htot(i,j) + h_neglect) + enddo + else + do i=is-1,ie+1 + ! Buoy_av has units (R L2 H-1 T-2) * (R-1 H) * H-1 = L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2 + buoy_av(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int(i)) / (htot(i,j) + h_neglect) + enddo + endif enddo if (CS%debug) then - call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(vol_dt_avail,'mle_Bodner: vol_dt_avail', G%HI, haloshift=1, & - scale=US%L_to_m**2*GV%H_to_m*US%s_to_T) - call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, & - scale=US%m_to_Z*US%L_T_to_m_s**2) + scale=US%L_to_m**2*GV%H_to_mks*US%s_to_T) + call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, scale=GV%m_to_H*US%L_T_to_m_s**2) endif ! U - Component @@ -885,12 +1015,12 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d if (G%OBCmaskCu(I,j) > 0.) then grid_dsd = sqrt(0.5*( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 )) * G%dyCu(I,j) ! L2 ~> m2 absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! T-1 ~> s-1 - h_sml = 0.5*( little_h(i,j) + little_h(i+1,j) ) ! Z ~> m - h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! Z ~> m - grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! L Z-1 T-2 ~> s-2 - r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! Z-2 T2 ~> m-2 s2 + h_sml = 0.5*( little_h(i,j) + little_h(i+1,j) ) ! H ~> m or kg m-3 + h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! H ~> m or kg m-3 + grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 + r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 - * ( ( h_big**2 ) * grd_b ) ) * r_wpup * US%L_to_Z * GV%Z_to_H + * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 endif @@ -926,12 +1056,12 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d if (G%OBCmaskCv(i,J) > 0.) then grid_dsd = sqrt(0.5*( G%dxCv(i,J)**2 + G%dyCv(i,J)**2 )) * G%dxCv(i,J) ! L2 ~> m2 absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! T-1 ~> s-1 - h_sml = 0.5*( little_h(i,j) + little_h(i,j+1) ) ! Z ~> m - h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! Z ~> m - grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! L Z-1 T-2 ~> s-2 - r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! Z-2 T2 ~> m-2 s2 + h_sml = 0.5*( little_h(i,j) + little_h(i,j+1) ) ! H ~> m or kg m-3 + h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! H ~> m or kg m-3 + grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 + r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 - * ( ( h_big**2 ) * grd_b ) ) * r_wpup * US%L_to_Z * GV%Z_to_H + * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 endif @@ -1065,25 +1195,30 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & - U_star_2d, & ! The wind friction velocity, calculated using + U_star_2d, & ! The wind friction velocity in thickness-based units, calculated using ! the Boussinesq reference density or the time-evolving surface density - ! in non-Boussinesq mode [Z T-1 ~> m s-1] + ! in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - Rml_av ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] - real :: Rho0(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + Rml_av ! g_Rho0 times the average mixed layer density or negative G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] + real :: Rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: rho_int(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int(SZI_(G)) ! Specific volume integrated through the surface layer [H R-1 ~> m4 kg-1 or m] real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] - real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] - real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: u_star ! surface friction velocity, interpolated to velocity points and recast into + ! thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1]. real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times ! pi squared [nondim] real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] - real :: dz_neglect ! tiny thickness that usually lost in roundoff and can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: I2htot ! Twice the total mixed layer thickness at velocity points [H ~> m or kg m-2] real :: z_topx2 ! depth of the top of a layer at velocity points [H ~> m or kg m-2] @@ -1113,11 +1248,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / dt - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 vonKar_x_pi2 = CS%vonKar * 9.8696 use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff*GV%H_to_Z if (.not.use_EOS) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & "An equation of state must be used with this module.") @@ -1126,33 +1260,56 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) "The Stanley parameterization is not available with the BML.") ! Extract the friction velocity from the forcing type. - call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) ! Fix this later for nkml >= 3. p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) - !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & - !$OMP I2htot,z_topx2,hx2,a) & + !$OMP parallel default(shared) private(Rho_ml,rho_int,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP SpV_ml,SpV_int,I2htot,z_topx2,hx2,a) & !$OMP firstprivate(uDml,vDml) - !$OMP do - do j=js-1,je+1 - do i=is-1,ie+1 - htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 - enddo - do k=1,nkml - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), tv%eqn_of_state, EOSdom) + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; rho_int(i) = 0.0 + enddo + do k=1,nkml + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho_ml(:), tv%eqn_of_state, EOSdom) + do i=is-1,ie+1 + rho_int(i) = rho_int(i) + h(i,j,k)*Rho_ml(i) + htot(i,j) = htot(i,j) + h(i,j,k) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + enddo + do i=is-1,ie+1 - Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) - htot(i,j) = htot(i,j) + h(i,j,k) - h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + Rml_av(i,j) = (g_Rho0*rho_int(i)) / (htot(i,j) + h_neglect) enddo enddo + else ! This is only used in non-Boussinesq mode. + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; SpV_int(i) = 0.0 + enddo + do k=1,nkml + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + do i=is-1,ie+1 + SpV_int(i) = SpV_int(i) + h(i,j,k)*SpV_ml(i) ! [H R-1 ~> m4 kg-1 or m] + htot(i,j) = htot(i,j) + h(i,j,k) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + enddo - do i=is-1,ie+1 - Rml_av(i,j) = (g_Rho0*Rml_av(i,j)) / (htot(i,j) + h_neglect) + ! Convert the vertically integrated specific volume into a negative variable with units of density. + do i=is-1,ie+1 + Rml_av(i,j) = (-GV%H_to_RZ*GV%g_Earth * SpV_int(i)) / (htot(i,j) + h_neglect) + enddo enddo - enddo + endif ! TO DO: ! 1. Mixing extends below the mixing layer to the mixed layer. Find it! @@ -1161,26 +1318,26 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! U - Component !$OMP do do j=js,je ; do I=is-1,ie - h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z + h_vel = 0.5*(htot(i,j) + htot(i+1,j)) u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & - (Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2) if (uDml(I) == 0) then do k=1,nkml ; uhml(I,j,k) = 0.0 ; enddo @@ -1212,26 +1369,26 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! V- component !$OMP do do J=js-1,je ; do i=is,ie - h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z + h_vel = 0.5*(htot(i,j) + htot(i,j+1)) u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & - (Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2) if (vDml(i) == 0) then do k=1,nkml ; vhml(i,J,k) = 0.0 ; enddo else @@ -1301,19 +1458,21 @@ end subroutine mixedlayer_restrat_BML !> Return the growth timescale for the submesoscale mixed layer eddies in [T ~> s] real function growth_time(u_star, hBL, absf, h_neg, vonKar, Kv_rest, restrat_coef) - real, intent(in) :: u_star !< Surface friction velocity [Z T-1 ~> m s-1] + real, intent(in) :: u_star !< Surface friction velocity in thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1] real, intent(in) :: hBL !< Boundary layer thickness including at least a neglible - !! value to keep it positive definite [Z ~> m] + !! value to keep it positive definite [H ~> m or kg m-2] real, intent(in) :: absf !< Absolute value of the Coriolis parameter [T-1 ~> s-1] - real, intent(in) :: h_neg !< A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] - real, intent(in) :: Kv_rest !< The background laminar vertical viscosity used for restratification [Z2 T-1 ~> m2 s-1] + real, intent(in) :: h_neg !< A tiny thickness that is usually lost in roundoff so can be + !! neglected [H ~> m or kg m-2] + real, intent(in) :: Kv_rest !< The background laminar vertical viscosity used for restratification, + !! rescaled into thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] real, intent(in) :: vonKar !< The von Karman constant, used to scale the turbulent limits !! on the restratification timescales [nondim] real, intent(in) :: restrat_coef !< An overall scaling factor for the restratification timescale [nondim] ! Local variables real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] - real :: Kv_eff ! An effective overall viscosity [Z2 T-1 ~> m2 s-1] + real :: Kv_eff ! An effective overall viscosity in thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] real :: pi2 ! A scaling constant that is approximately pi^2 [nondim] ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + Kv_water @@ -1354,7 +1513,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, real :: ustar_min_dflt ! The default value for RESTRAT_USTAR_MIN [Z T-1 ~> m s-1] real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] - real :: BLD_units ! Set to either H_to_m or Z_to_m depending on scheme [m H-1 or m Z-1 ~> 1] ! This include declares and sets the variable "version". # include "version_variable.h" integer :: i, j @@ -1429,7 +1587,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "a division-by-zero in the limit when u* and the buoyancy flux are zero. "//& "The default is less than the molecular viscosity of water times the Coriolis "//& "parameter a micron away from the equator.", & - units="m2 s-2", default=1.0e-24) + units="m2 s-2", default=1.0e-24) ! This parameter stays in MKS units. call get_param(param_file, mdl, "TAIL_DH", CS%MLE_tail_dh, & "Fraction by which to extend the mixed-layer restratification "//& "depth used for a smoother stream function at the base of "//& @@ -1464,7 +1622,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "USE_STANLEY_ML", CS%use_Stanley_ML, & "If true, turn on Stanley SGS T variance parameterization "// & "in ML restrat code.", default=.false.) - if (CS%use_stanley_ml) then + if (CS%use_Stanley_ML) then call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & "Coefficient correlating the temperature gradient and SGS T variance.", & units="nondim", default=-1.0, do_not_log=.true.) @@ -1520,23 +1678,21 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "A small viscosity that sets a floor on the momentum mixing rate during "//& "restratification. If this is positive, it will prevent some possible "//& "divisions by zero even if ustar, RESTRAT_USTAR_MIN, and f are all 0.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T*(US%Z_to_m*GV%m_to_H)) call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & units="s-1", default=7.2921e-5, scale=US%T_to_s) - ustar_min_dflt = 2.0e-4 * omega * (GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) + ustar_min_dflt = 2.0e-4 * omega * (GV%Angstrom_Z + GV%dZ_subroundoff) call get_param(param_file, mdl, "RESTRAT_USTAR_MIN", CS%ustar_min, & "The minimum value of ustar that will be used by the mixed layer "//& "restratification module. This can be tiny, but if this is greater than 0, "//& "it will prevent divisions by zero when f and KV_RESTRAT are zero.", & - units="m s-1", default=US%Z_to_m*US%s_to_T*ustar_min_dflt, scale=US%m_to_Z*US%T_to_s) + units="m s-1", default=US%Z_to_m*US%s_to_T*ustar_min_dflt, scale=GV%m_to_H*US%T_to_s) endif CS%diag => diag flux_to_kg_per_s = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T - if (CS%use_Bodner) then; BLD_units = US%Z_to_m - else; BLD_units = GV%H_to_m; endif CS%id_uhml = register_diag_field('ocean_model', 'uhml', diag%axesCuL, Time, & 'Zonal Thickness Flux to Restratify Mixed Layer', & @@ -1550,13 +1706,13 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 'Mixed Layer Meridional Restratification Timescale', 's', conversion=US%T_to_s) CS%id_MLD = register_diag_field('ocean_model', 'MLD_restrat', diag%axesT1, Time, & 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', & - 'm', conversion=BLD_units) + 'm', conversion=GV%H_to_m) CS%id_BLD = register_diag_field('ocean_model', 'BLD_restrat', diag%axesT1, Time, & 'Boundary Layer Depth as used in the mixed-layer restratification parameterization', & - 'm', conversion=BLD_units) + 'm', conversion=GV%H_to_m) CS%id_Rml = register_diag_field('ocean_model', 'ML_buoy_restrat', diag%axesT1, Time, & 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', & - 'm s-2', conversion=US%m_to_Z*(US%L_T_to_m_s**2)) + 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_uDml = register_diag_field('ocean_model', 'udml_restrat', diag%axesCu1, Time, & 'Transport stream function amplitude for zonal restratification of mixed layer', & 'm3 s-1', conversion=GV%H_to_m*(US%L_to_m**2)*US%s_to_T) @@ -1572,7 +1728,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, if (CS%use_Bodner) then CS%id_wpup = register_diag_field('ocean_model', 'MLE_wpup', diag%axesT1, Time, & 'Vertical turbulent momentum flux in Bodner mixed layer restratificiation parameterization', & - 'm2 s-2', conversion=(US%Z_to_m*US%s_to_T)**2) + 'm2 s-2', conversion=US%L_to_m*GV%H_to_m*US%s_to_T**2) CS%id_ustar = register_diag_field('ocean_model', 'MLE_ustar', diag%axesT1, Time, & 'Surface turbulent friction velicity, u*, in Bodner mixed layer restratificiation parameterization', & 'm s-1', conversion=(US%Z_to_m*US%s_to_T)) @@ -1599,6 +1755,7 @@ subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, rest type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure ! Local variables + character(len=64) :: mom_flux_units logical :: mixedlayer_restrat_init, use_Bodner ! Check to see if this module will be used @@ -1624,14 +1781,15 @@ subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, rest allocate(CS%MLD_filtered_slow(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) call register_restart_field(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", .false., restart_CS, & longname="Slower time-filtered MLD for use in MLE", & - units=get_thickness_units(GV), conversion=GV%H_to_MKS) ! UNITS ARE WRONG -AJA + units=get_thickness_units(GV), conversion=GV%H_to_MKS) endif if (use_Bodner) then ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. + mom_flux_units = "m2 s-2" ; if (.not.GV%Boussinesq) mom_flux_units = "kg m-1 s-2" allocate(CS%wpup_filtered(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) call register_restart_field(CS%wpup_filtered, "MLE_Bflux", .false., restart_CS, & longname="Time-filtered vertical turbulent momentum flux for use in MLE", & - units='m2 s-2', conversion=(US%Z_to_m*US%s_to_T)**2 ) + units=mom_flux_units, conversion=US%L_to_m*GV%H_to_mks*US%s_to_T**2 ) endif end subroutine mixedlayer_restrat_register_restarts From d60c2e064e601d565cb4fa260ed885057b73fa8f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Aug 2023 05:46:14 -0400 Subject: [PATCH 065/146] *Non-Boussinesq revision of kappa_shear Remove dependency on the Boussinesq reference density in MOM_kappa_shear when in fully non-Boussinesq mode. This is done by using calls to calculate_density and calculate_specific_vol_derivs to calculate the thermal expansion and haline contraction coefficients, and by using thickness_to_dz to convert layer thicknesses to vertical distances. A large part of the changes to the kappa_shear code involved refactoring it to differentiate between thicknesses and geometric heights by working internally with dynamic viscosities and diffusivities in non-Boussinesq mode, and to keep thicknesses in thickness units rather than converting them to distances in height units. The internal variable dz was renamed to h_lay in Calculate_kappa_shear and Calc_kappa_shear_vertex for greater clarity. The scaling factor for dz_massless is now set to (US%Z_to_m*GV%m_to_H) in Calculate_kappa_shear to reduce the dependency on the Boussinesq reference density; this does not impact answers if RHO_0 = RHO_KV_CONVERT. The internal changes related to this are extensive. This commit includes changing the units of 63 internal variables, and the addition or renaming of 17 internal variables. There are 2 new arguments to find_kappa_tke (one is necessary to differentiate thicknesses from vertical distances and while the other is used to preserve Boussinesq-mode answers), and 1 new argument to kappa_shear_column plus the renaming of another. The units of 13 internal subroutine arguments and 3 elements of the Kappa_shear_CS type change. A total of 6 thickness unit conversion factors were eliminated with these changes. The answers will change in non-Boussinesq mode when the Jackson et al. shear mixing parameterization is in use, but they are bitwise identical in all Boussinesq test cases. There are no changes to external interfaces. --- .../vertical/MOM_kappa_shear.F90 | 569 ++++++++++-------- 1 file changed, 330 insertions(+), 239 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 191b88de0a..81ab0661cc 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -3,18 +3,20 @@ module MOM_kappa_shear ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr -use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_debugging, only : hchksum, Bchksum -use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_debugging, only : hchksum, Bchksum +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_specific_vol_derivs implicit none ; private @@ -53,12 +55,12 @@ module MOM_kappa_shear !! the buoyancy and shear scales in the diffusivity !! equation, 0 to eliminate the shear scale [nondim]. real :: TKE_bg !< The background level of TKE [Z2 T-2 ~> m2 s-2]. - real :: kappa_0 !< The background diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: kappa_0 !< The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_seed !< A moderately large seed value of diapycnal diffusivity that !! is used as a starting turbulent diffusivity in the iterations !! to findind an energetically constrained solution for the - !! shear-driven diffusivity [Z2 T-1 ~> m2 s-1]. - real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [Z2 T-1 ~> m2 s-1]. + !! shear-driven diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_tol_err !< The fractional error in kappa that is tolerated [nondim]. real :: Prandtl_turb !< Prandtl number used to convert Kd_shear into viscosity [nondim]. integer :: nkml !< The number of layers in the mixed layer, as @@ -101,7 +103,7 @@ module MOM_kappa_shear type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. !>@{ Diagnostic IDs - integer :: id_Kd_shear = -1, id_TKE = -1, id_ILd2 = -1, id_dz_Int = -1 + integer :: id_Kd_shear = -1, id_TKE = -1 !>@} end type Kappa_shear_CS @@ -144,30 +146,33 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & - h_2d, & ! A 2-D version of h, but converted to [Z ~> m]. + h_2d, & ! A 2-D version of h [H ~> m or kg m-2]. + dz_2d, & ! Vertical distance between interface heights [Z ~> m]. u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. T_2d, S_2d, rho_2d ! 2-D versions of T [C ~> degC], S [S ~> ppt], and rho [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)+1) :: & - kappa_2d, & ! 2-D version of kappa_io [Z2 T-1 ~> m2 s-1]. + kappa_2d, & ! 2-D version of kappa_io [H Z T-1 ~> m2 s-1 or Pa s] tke_2d ! 2-D version tke_io [Z2 T-2 ~> m2 s-2]. real, dimension(SZK_(GV)) :: & - Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. - dz, & ! The layer thickness [Z ~> m]. - u0xdz, & ! The initial zonal velocity times dz [Z L T-1 ~> m2 s-1]. - v0xdz, & ! The initial meridional velocity times dz [Z L T-1 ~> m2 s-1]. - T0xdz, & ! The initial temperature times dz [C Z ~> degC m]. - S0xdz ! The initial salinity times dz [S Z ~> ppt m]. + Idz, & ! The inverse of the thickness of the merged layers [H-1 ~> m2 kg-1]. + h_lay, & ! The layer thickness [H ~> m or kg m-2] + dz_lay, & ! The geometric layer thickness in height units [Z ~> m] + u0xdz, & ! The initial zonal velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + v0xdz, & ! The initial meridional velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + T0xdz, & ! The initial temperature times thickness [C H ~> degC m or degC kg m-2] or if + ! temperature is not a state variable, the density times thickness [R H ~> kg m-2 or kg2 m-3] + S0xdz ! The initial salinity times dz [S H ~> ppt m or ppt kg m-2]. real, dimension(SZK_(GV)+1) :: & - kappa, & ! The shear-driven diapycnal diffusivity at an interface [Z2 T-1 ~> m2 s-1]. + kappa, & ! The shear-driven diapycnal diffusivity at an interface [H Z T-1 ~> m2 s-1 or Pa s] tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [Z2 T-2 ~> m2 s-2]. - kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + kappa_avg, & ! The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. - real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. + real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. - 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 :: dz_in_lay ! The running sum of the thickness in a layer [H ~> m or kg m-2] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1] + real :: dz_massless ! A layer thickness that is considered massless [H ~> m or kg m-2] logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. @@ -183,13 +188,17 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & use_temperature = associated(tv%T) k0dt = dt*CS%kappa_0 - dz_massless = 0.1*sqrt(k0dt) + dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) !$OMP parallel do default(private) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,tv,G,GV,US, & !$OMP CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) do j=js,je + + ! Convert layer thicknesses into geometric thickness in height units. + call thickness_to_dz(h, tv, dz_2d, j, G, GV) + do k=1,nz ; do i=is,ie - h_2d(i,k) = h(i,j,k)*GV%H_to_Z + h_2d(i,k) = h(i,j,k) u_2d(i,k) = u_in(i,j,k) ; v_2d(i,k) = v_in(i,j,k) enddo ; enddo if (use_temperature) then ; do k=1,nz ; do i=is,ie @@ -203,26 +212,28 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & !--------------------------------------- do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! call cpu_clock_begin(id_clock_setup) + ! Store a transposed version of the initial arrays. ! Any elimination of massless layers would occur here. if (CS%eliminate_massless) then nzc = 1 do k=1,nz ! Zero out the thicknesses of all layers, even if they are unused. - dz(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 + h_lay(k) = 0.0 ; dz_lay(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 T0xdz(k) = 0.0 ; S0xdz(k) = 0.0 ! Add a new layer if this one has mass. -! if ((dz(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless)) nzc = nzc+1 - if ((k>CS%nkml) .and. (dz(nzc) > 0.0) .and. & +! if ((h_lay(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless)) nzc = nzc+1 + if ((k>CS%nkml) .and. (h_lay(nzc) > 0.0) .and. & (h_2d(i,k) > dz_massless)) nzc = nzc+1 ! Only merge clusters of massless layers. -! if ((dz(nzc) > dz_massless) .or. & -! ((dz(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless))) nzc = nzc+1 +! if ((h_lay(nzc) > dz_massless) .or. & +! ((h_lay(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless))) nzc = nzc+1 kc(k) = nzc - dz(nzc) = dz(nzc) + h_2d(i,k) + h_lay(nzc) = h_lay(nzc) + h_2d(i,k) + dz_lay(nzc) = dz_lay(nzc) + dz_2d(i,k) u0xdz(nzc) = u0xdz(nzc) + u_2d(i,k)*h_2d(i,k) v0xdz(nzc) = v0xdz(nzc) + v_2d(i,k)*h_2d(i,k) if (use_temperature) then @@ -236,7 +247,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kc(nz+1) = nzc+1 ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + do k=1,nzc ; Idz(k) = 1.0 / h_lay(k) ; enddo ! Now determine kf, the fractional weight of interface kc when ! interpolating between interfaces kc and kc+1. @@ -251,21 +262,23 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kf(nz+1) = 0.0 else do k=1,nz - dz(k) = h_2d(i,k) - u0xdz(k) = u_2d(i,k)*dz(k) ; v0xdz(k) = v_2d(i,k)*dz(k) + h_lay(k) = h_2d(i,k) + dz_lay(k) = dz_2d(i,k) + u0xdz(k) = u_2d(i,k)*h_lay(k) ; v0xdz(k) = v_2d(i,k)*h_lay(k) enddo if (use_temperature) then do k=1,nz - T0xdz(k) = T_2d(i,k)*dz(k) ; S0xdz(k) = S_2d(i,k)*dz(k) + T0xdz(k) = T_2d(i,k)*h_lay(k) ; S0xdz(k) = S_2d(i,k)*h_lay(k) enddo else do k=1,nz - T0xdz(k) = rho_2d(i,k)*dz(k) ; S0xdz(k) = rho_2d(i,k)*dz(k) + T0xdz(k) = rho_2d(i,k)*h_lay(k) ; S0xdz(k) = rho_2d(i,k)*h_lay(k) enddo endif nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif + f2 = 0.25 * ((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = p_surf(i,j) @@ -277,7 +290,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & do K=1,nzc+1 ; kappa(K) = CS%kappa_seed ; enddo call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) ! call cpu_clock_begin(id_clock_setup) @@ -312,9 +325,9 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif ; enddo ! i-loop do K=1,nz+1 ; do i=is,ie - kappa_io(i,j,K) = G%mask2dT(i,j) * GV%Z_to_H*kappa_2d(i,K) + 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) * GV%Z_to_H*kappa_2d(i,K) ) * CS%Prandtl_turb + kv_io(i,j,K) = ( G%mask2dT(i,j) * kappa_2d(i,K) ) * CS%Prandtl_turb enddo ; enddo enddo ! end of j-loop @@ -368,32 +381,36 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ !! call to kappa_shear_init. ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dz_3d ! Vertical distance between interface heights [Z ~> m]. real, dimension(SZIB_(G),SZK_(GV)) :: & - h_2d, & ! A 2-D version of h, but converted to [Z ~> m]. + h_2d, & ! A 2-D version of h [H ~> m or kg m-2]. + dz_2d, & ! Vertical distance between interface heights [Z ~> m]. u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. T_2d, S_2d, rho_2d ! 2-D versions of T [C ~> degC], S [S ~> ppt], and rho [R ~> kg m-3]. real, dimension(SZIB_(G),SZK_(GV)+1,2) :: & - kappa_2d ! Quasi 2-D versions of kappa_io [Z2 T-1 ~> m2 s-1]. + kappa_2d ! Quasi 2-D versions of kappa_io [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZIB_(G),SZK_(GV)+1) :: & tke_2d ! 2-D version tke_io [Z2 T-2 ~> m2 s-2]. real, dimension(SZK_(GV)) :: & - Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. - dz, & ! The layer thickness [Z ~> m]. - u0xdz, & ! The initial zonal velocity times dz [L Z T-1 ~> m2 s-1]. - v0xdz, & ! The initial meridional velocity times dz [L Z T-1 ~> m2 s-1]. - T0xdz, & ! The initial temperature times dz [C Z ~> degC m]. - S0xdz ! The initial salinity times dz [S Z ~> ppt m]. + Idz, & ! The inverse of the thickness of the merged layers [H-1 ~> m2 kg-1]. + h_lay, & ! The layer thickness [H ~> m or kg m-2] + dz_lay, & ! The geometric layer thickness in height units [Z ~> m] + u0xdz, & ! The initial zonal velocity times dz [L H T-1 ~> m2 s-1 or kg m-1 s-1]. + v0xdz, & ! The initial meridional velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + T0xdz, & ! The initial temperature times dz [C H ~> degC m or degC kg m-2] + S0xdz ! The initial salinity times dz [S H ~> ppt m or ppt kg m-2] real, dimension(SZK_(GV)+1) :: & - kappa, & ! The shear-driven diapycnal diffusivity at an interface [Z2 T-1 ~> m2 s-1]. + kappa, & ! The shear-driven diapycnal diffusivity at an interface [H Z T-1 ~> m2 s-1 or Pa s] tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [Z2 T-2 ~> m2 s-2]. - kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + kappa_avg, & ! The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. - 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 :: dz_in_lay ! The running sum of the thickness in a layer [H ~> m or kg m-2] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1] + real :: dz_massless ! A layer thickness that is considered massless [H ~> m or kg m-2] 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 @@ -412,9 +429,12 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ use_temperature = associated(tv%T) k0dt = dt*CS%kappa_0 - dz_massless = 0.1*sqrt(k0dt) + dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb + ! Convert layer thicknesses into geometric thickness in height units. + call thickness_to_dz(h, tv, dz_3d, G, GV, US, halo_size=1) + !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,tv,G,GV, & !$OMP US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io,I_Prandtl) do J=JsB,JeB @@ -443,13 +463,17 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ ((G%mask2dT(i+1,j) * h(i+1,j,k)) * S_in(i+1,j,k) + & (G%mask2dT(i,j+1) * h(i,j+1,k)) * S_in(i,j+1,k)) ) * I_hwt endif - h_2d(I,k) = GV%H_to_Z * ((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & - (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) ) / & - ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & - (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) -! h_2d(I,k) = 0.25*((h(i,j,k) + h(i+1,j+1,k)) + (h(i+1,j,k) + h(i,j+1,k)))*GV%H_to_Z + h_2d(I,k) = ((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) + dz_2d(I,k) = ((G%mask2dT(i,j) * dz_3d(i,j,k) + G%mask2dT(i+1,j+1) * dz_3d(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * dz_3d(i+1,j,k) + G%mask2dT(i,j+1) * dz_3d(i,j+1,k)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) +! h_2d(I,k) = 0.25*((h(i,j,k) + h(i+1,j+1,k)) + (h(i+1,j,k) + h(i,j+1,k))) ! h_2d(I,k) = ((h(i,j,k)**2 + h(i+1,j+1,k)**2) + & -! (h(i+1,j,k)**2 + h(i,j+1,k)**2))*GV%H_to_Z * I_hwt +! (h(i+1,j,k)**2 + h(i,j+1,k)**2)) * I_hwt enddo ; enddo if (.not.use_temperature) then ; do k=1,nz ; do I=IsB,IeB rho_2d(I,k) = GV%Rlay(k) @@ -467,20 +491,21 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ nzc = 1 do k=1,nz ! Zero out the thicknesses of all layers, even if they are unused. - dz(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 + h_lay(k) = 0.0 ; dz_lay(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 T0xdz(k) = 0.0 ; S0xdz(k) = 0.0 ! Add a new layer if this one has mass. -! if ((dz(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless)) nzc = nzc+1 - if ((k>CS%nkml) .and. (dz(nzc) > 0.0) .and. & +! if ((h_lay(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless)) nzc = nzc+1 + if ((k>CS%nkml) .and. (h_lay(nzc) > 0.0) .and. & (h_2d(I,k) > dz_massless)) nzc = nzc+1 ! Only merge clusters of massless layers. -! if ((dz(nzc) > dz_massless) .or. & -! ((dz(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless))) nzc = nzc+1 +! if ((h_lay(nzc) > dz_massless) .or. & +! ((h_lay(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless))) nzc = nzc+1 kc(k) = nzc - dz(nzc) = dz(nzc) + h_2d(I,k) + h_lay(nzc) = h_lay(nzc) + h_2d(I,k) + dz_lay(nzc) = dz_lay(nzc) + dz_2d(I,k) u0xdz(nzc) = u0xdz(nzc) + u_2d(I,k)*h_2d(I,k) v0xdz(nzc) = v0xdz(nzc) + v_2d(I,k)*h_2d(I,k) if (use_temperature) then @@ -494,7 +519,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ kc(nz+1) = nzc+1 ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + do k=1,nzc ; Idz(k) = 1.0 / h_lay(k) ; enddo ! Now determine kf, the fractional weight of interface kc when ! interpolating between interfaces kc and kc+1. @@ -509,21 +534,23 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ kf(nz+1) = 0.0 else do k=1,nz - dz(k) = h_2d(I,k) - u0xdz(k) = u_2d(I,k)*dz(k) ; v0xdz(k) = v_2d(I,k)*dz(k) + h_lay(k) = h_2d(I,k) + dz_lay(k) = dz_2d(I,k) + u0xdz(k) = u_2d(I,k)*h_lay(k) ; v0xdz(k) = v_2d(I,k)*h_lay(k) enddo if (use_temperature) then do k=1,nz - T0xdz(k) = T_2d(I,k)*dz(k) ; S0xdz(k) = S_2d(I,k)*dz(k) + T0xdz(k) = T_2d(I,k)*h_lay(k) ; S0xdz(k) = S_2d(I,k)*h_lay(k) enddo else do k=1,nz - T0xdz(k) = rho_2d(I,k)*dz(k) ; S0xdz(k) = rho_2d(I,k)*dz(k) + T0xdz(k) = rho_2d(I,k)*h_lay(k) ; S0xdz(k) = rho_2d(I,k)*h_lay(k) enddo endif nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif + f2 = G%CoriolisBu(I,J)**2 surface_pres = 0.0 if (associated(p_surf)) then @@ -545,7 +572,7 @@ 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) = CS%kappa_seed ; enddo call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) ! call cpu_clock_begin(Id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. @@ -578,11 +605,11 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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) * GV%Z_to_H*kappa_2d(I,K,J2) ) * CS%Prandtl_turb + kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_2d(I,K,J2) ) * CS%Prandtl_turb 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. - kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * GV%Z_to_H * & + kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * & ((kappa_2d(I-1,K,J2m1) + kappa_2d(I,K,J2)) + & (kappa_2d(I-1,K,J2) + kappa_2d(I,K,J2m1))) enddo ; enddo ; endif @@ -601,11 +628,11 @@ end subroutine Calc_kappa_shear_vertex !> This subroutine calculates shear-driven diffusivity and TKE in a single column -subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & +subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_lay, & u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, tke_avg, tv, CS, GV, US) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZK_(GV)+1), & - intent(inout) :: kappa !< The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + intent(inout) :: kappa !< The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZK_(GV)+1), & intent(out) :: tke !< The Turbulent Kinetic Energy per unit mass at !! an interface [Z2 T-2 ~> m2 s-2]. @@ -613,17 +640,20 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & real, intent(in) :: f2 !< The square of the Coriolis parameter [T-2 ~> s-2]. real, intent(in) :: surface_pres !< The surface pressure [R L2 T-2 ~> Pa]. real, dimension(SZK_(GV)), & - intent(in) :: dz !< The layer thickness [Z ~> m]. + intent(in) :: hlay !< The layer thickness [H ~> m or kg m-2] + real, dimension(SZK_(GV)), & + intent(in) :: dz_lay !< The geometric layer thickness in height units [Z ~> m] real, dimension(SZK_(GV)), & - intent(in) :: u0xdz !< The initial zonal velocity times dz [Z L T-1 ~> m2 s-1]. + intent(in) :: u0xdz !< The initial zonal velocity times hlay [H L T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZK_(GV)), & - intent(in) :: v0xdz !< The initial meridional velocity times dz [Z L T-1 ~> m2 s-1]. + intent(in) :: v0xdz !< The initial meridional velocity times the + !! layer thickness [H L T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZK_(GV)), & - intent(in) :: T0xdz !< The initial temperature times dz [C Z ~> degC m]. + intent(in) :: T0xdz !< The initial temperature times hlay [C H ~> degC m or degC kg m-2] real, dimension(SZK_(GV)), & - intent(in) :: S0xdz !< The initial salinity times dz [S Z ~> ppt m]. + intent(in) :: S0xdz !< The initial salinity times hlay [S H ~> ppt m or ppt kg m-2] real, dimension(SZK_(GV)+1), & - intent(out) :: kappa_avg !< The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + intent(out) :: kappa_avg !< The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZK_(GV)+1), & intent(out) :: tke_avg !< The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. real, intent(in) :: dt !< Time increment [T ~> s]. @@ -646,47 +676,56 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & real, dimension(nzc+1) :: & N2, & ! The squared buoyancy frequency at an interface [T-2 ~> s-2]. - dz_Int, & ! The extent of a finite-volume space surrounding an interface, - ! as used in calculating kappa and TKE [Z ~> m]. + h_Int, & ! The extent of a finite-volume space surrounding an interface, + ! as used in calculating kappa and TKE [H ~> m or kg m-2] + dz_Int, & ! The vertical distance with the space surrounding an interface, + ! as used in calculating kappa and TKE [Z ~> m] + dz_h_Int, & ! The ratio of the vertical distances to the thickness around an + ! interface [Z H-1 ~> nondim or m3 kg-1]. In non-Boussinesq mode + ! this is the specific volume, otherwise it is a scaling factor. I_dz_int, & ! The inverse of the distance between velocity & density points ! above and below an interface [Z-1 ~> m-1]. This is used to - ! calculate N2, shear, and fluxes, and it might differ from - ! 1/dz_Int, as they have different uses. + ! calculate N2, shear and fluxes. S2, & ! The squared shear at an interface [T-2 ~> s-2]. a1, & ! a1 is the coupling between adjacent interfaces in the TKE, - ! velocity, and density equations [Z ~> m] + ! velocity, and density equations [H ~> m or kg m-2] c1, & ! c1 is used in the tridiagonal (and similar) solvers [nondim]. - k_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. - kappa_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. - kappa_out, & ! The kappa that results from the kappa equation [Z2 T-1 ~> m2 s-1]. - kappa_mid, & ! The average of the initial and predictor estimates of kappa [Z2 T-1 ~> m2 s-1]. + k_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1] + kappa_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1] + kappa_out, & ! The kappa that results from the kappa equation [H Z T-1 ~> m2 s-1 or Pa s] + kappa_mid, & ! The average of the initial and predictor estimates of kappa [H Z T-1 ~> m2 s-1 or Pa s] tke_pred, & ! The value of TKE from a predictor step [Z2 T-2 ~> m2 s-2]. - kappa_pred, & ! The value of kappa from a predictor step [Z2 T-1 ~> m2 s-1]. + kappa_pred, & ! The value of kappa from a predictor step [H Z T-1 ~> m2 s-1 or Pa s] pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. T_int, & ! The temperature interpolated to an interface [C ~> degC]. Sal_int, & ! The salinity interpolated to an interface [S ~> ppt]. dbuoy_dT, & ! The partial derivative of buoyancy with changes in temperature [Z T-2 C-1 ~> m s-2 degC-1] dbuoy_dS, & ! The partial derivative of buoyancy with changes in salinity [Z T-2 S-1 ~> m s-2 ppt-1] + dSpV_dT, & ! The partial derivative of specific volume with changes in temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! The partial derivative of specific volume with changes in salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + rho_int, & ! The in situ density interpolated to an interface [R ~> kg m-3] I_L2_bdry, & ! The inverse of the square of twice the harmonic mean - ! distance to the top and bottom boundaries [Z-2 ~> m-2]. - K_Q, & ! Diffusivity divided by TKE [T ~> s]. - K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [T ~> s]. - local_src_avg, & ! The time-integral of the local source [nondim]. + ! distance to the top and bottom boundaries [H-1 Z-1 ~> m-2 or m kg-1]. + K_Q, & ! Diffusivity divided by TKE [H T Z-1 ~> s or kg s m-3] + K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [H T Z-1 ~> s or kg s m-3] + local_src_avg, & ! The time-integral of the local source [nondim] tol_min, & ! Minimum tolerated ksrc for the corrector step [T-1 ~> s-1]. tol_max, & ! Maximum tolerated ksrc for the corrector step [T-1 ~> s-1]. tol_chg, & ! The tolerated kappa change integrated over a timestep [nondim]. dist_from_top, & ! The distance from the top surface [Z ~> m]. + h_from_top, & ! The total thickness above an interface [H ~> m or kg m-2] local_src ! The sum of all sources of kappa, including kappa_src and - ! sources from the elliptic term [T-1 ~> s-1]. + ! sources from the elliptic term [T-1 ~> s-1] real :: dist_from_bot ! The distance from the bottom surface [Z ~> m]. - real :: b1 ! The inverse of the pivot in the tridiagonal equations [Z-1 ~> m-1]. - real :: bd1 ! A term in the denominator of b1 [Z ~> m]. + real :: h_from_bot ! The total thickness below and interface [H ~> m or kg m-2] + real :: b1 ! The inverse of the pivot in the tridiagonal equations [H-1 ~> m-1 or m2 kg-1]. + real :: bd1 ! A term in the denominator of b1 [H ~> m or kg m-2]. real :: d1 ! 1 - c1 in the tridiagonal equations [nondim] - real :: gR0 ! A conversion factor from Z to pressure, given by Rho_0 times g - ! [R L2 T-2 Z-1 ~> kg m-2 s-2]. + real :: gR0 ! A conversion factor from H to pressure, Rho_0 times g in Boussinesq + ! mode, or just g when non-Boussinesq [R L2 T-2 H-1 ~> kg m-2 s-2 or m s-2]. real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. - real :: Norm ! A factor that normalizes two weights to 1 [Z-2 ~> m-2]. + real :: Norm ! A factor that normalizes two weights to 1 [H-2 ~> m-2 or m4 kg-2]. real :: tol_dksrc ! Tolerance for the change in the kappa source within an iteration ! relative to the local source [nondim]. This must be greater than 1. real :: tol2 ! The tolerance for the change in the kappa source within an iteration @@ -702,8 +741,11 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! gives acceptably small changes in k_src [T ~> s]. real :: Idtt ! Idtt = 1 / dt_test [T-1 ~> s-1]. real :: dt_inc ! An increment to dt_test that is being tested [T ~> s]. - - real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. + real :: wt_a ! The fraction of a layer thickness identified with the interface + ! above a layer [nondim] + real :: wt_b ! The fraction of a layer thickness identified with the interface + ! below a layer [nondim] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1]. logical :: valid_dt ! If true, all levels so far exhibit acceptably small changes in k_src. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. @@ -718,8 +760,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] Ri_crit = CS%Rino_crit - gR0 = GV%Rho0 * GV%g_Earth - g_R0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) + gR0 = GV%H_to_RZ * GV%g_Earth + g_R0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 k0dt = dt*CS%kappa_0 tol_dksrc = CS%kappa_src_max_chg @@ -735,27 +777,37 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + do k=1,nzc ; Idz(k) = 1.0 / dz_lay(k) ; enddo ! Set up I_dz_int as the inverse of the distance between ! adjacent layer centers. - I_dz_int(1) = 2.0 / dz(1) - dist_from_top(1) = 0.0 + I_dz_int(1) = 2.0 / dz_lay(1) + dist_from_top(1) = 0.0 ; h_from_top(1) = 0.0 do K=2,nzc - I_dz_int(K) = 2.0 / (dz(k-1) + dz(k)) - dist_from_top(K) = dist_from_top(K-1) + dz(k-1) + I_dz_int(K) = 2.0 / (dz_lay(k-1) + dz_lay(k)) + dist_from_top(K) = dist_from_top(K-1) + dz_lay(k-1) + h_from_top(K) = h_from_top(K-1) + hlay(k-1) + enddo + I_dz_int(nzc+1) = 2.0 / dz_lay(nzc) + + ! Find the inverse of the squared distances from the boundaries. + dist_from_bot = 0.0 ; h_from_bot = 0.0 + do K=nzc,2,-1 + dist_from_bot = dist_from_bot + dz_lay(k) + h_from_bot = h_from_bot + hlay(k) + I_L2_bdry(K) = ((dist_from_top(K) + dist_from_bot) * (h_from_top(K) + h_from_bot)) / & + ((dist_from_top(K) * dist_from_bot) * (h_from_top(K) * h_from_bot)) enddo - I_dz_int(nzc+1) = 2.0 / dz(nzc) ! Determine the velocities and thicknesses after eliminating massless ! layers and applying a time-step of background diffusion. if (nzc > 1) then a1(2) = k0dt*I_dz_int(2) - b1 = 1.0 / (dz(1) + a1(2)) + b1 = 1.0 / (hlay(1) + a1(2)) u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) - c1(2) = a1(2) * b1 ; d1 = dz(1) * b1 ! = 1 - c1 + c1(2) = a1(2) * b1 ; d1 = hlay(1) * b1 ! = 1 - c1 do k=2,nzc-1 - bd1 = dz(k) + d1*a1(k) + bd1 = hlay(k) + d1*a1(k) a1(k+1) = k0dt*I_dz_int(k+1) b1 = 1.0 / (bd1 + a1(k+1)) u(k) = b1 * (u0xdz(k) + a1(k)*u(k-1)) @@ -767,11 +819,11 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! rho or T and S have insulating boundary conditions, u & v use no-slip ! bottom boundary conditions (if kappa0 > 0). ! For no-slip bottom boundary conditions - b1 = 1.0 / ((dz(nzc) + d1*a1(nzc)) + k0dt*I_dz_int(nzc+1)) + b1 = 1.0 / ((hlay(nzc) + d1*a1(nzc)) + k0dt*I_dz_int(nzc+1)) u(nzc) = b1 * (u0xdz(nzc) + a1(nzc)*u(nzc-1)) v(nzc) = b1 * (v0xdz(nzc) + a1(nzc)*v(nzc-1)) ! For insulating boundary conditions - b1 = 1.0 / (dz(nzc) + d1*a1(nzc)) + b1 = 1.0 / (hlay(nzc) + d1*a1(nzc)) T(nzc) = b1 * (T0xdz(nzc) + a1(nzc)*T(nzc-1)) Sal(nzc) = b1 * (S0xdz(nzc) + a1(nzc)*Sal(nzc-1)) do k=nzc-1,1,-1 @@ -780,9 +832,9 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & enddo else ! This is correct, but probably unnecessary. - b1 = 1.0 / (dz(1) + k0dt*I_dz_int(2)) + b1 = 1.0 / (hlay(1) + k0dt*I_dz_int(2)) u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) - b1 = 1.0 / dz(1) + b1 = 1.0 / hlay(1) T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) endif @@ -792,33 +844,66 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! layers have thin cells, and the total thickness adds up properly. ! The top- and bottom- interfaces have zero thickness, consistent with ! adding additional zero thickness layers. - dz_Int(1) = 0.0 ; dz_Int(2) = dz(1) + h_Int(1) = 0.0 ; h_Int(2) = hlay(1) + dz_Int(1) = 0.0 ; dz_Int(2) = dz_lay(1) do K=2,nzc-1 - Norm = 1.0 / (dz(k)*(dz(k-1)+dz(k+1)) + 2.0*dz(k-1)*dz(k+1)) - dz_Int(K) = dz_Int(K) + dz(k) * ( ((dz(k)+dz(k+1)) * dz(k-1)) * Norm) - dz_Int(K+1) = dz(k) * ( ((dz(k-1)+dz(k)) * dz(k+1)) * Norm) + Norm = 1.0 / (hlay(k)*(hlay(k-1)+hlay(k+1)) + 2.0*hlay(k-1)*hlay(k+1)) + wt_a = ((hlay(k)+hlay(k+1)) * hlay(k-1)) * Norm + wt_b = ((hlay(k-1)+hlay(k)) * hlay(k+1)) * Norm + h_Int(K) = h_Int(K) + hlay(k) * wt_a + h_Int(K+1) = hlay(k) * wt_b + dz_Int(K) = dz_Int(K) + dz_lay(k) * wt_a + dz_Int(K+1) = dz_lay(k) * wt_b enddo - dz_Int(nzc) = dz_Int(nzc) + dz(nzc) ; dz_Int(nzc+1) = 0.0 + h_Int(nzc) = h_Int(nzc) + hlay(nzc) ; h_Int(nzc+1) = 0.0 + dz_Int(nzc) = dz_Int(nzc) + dz_lay(nzc) ; dz_Int(nzc+1) = 0.0 - dist_from_bot = 0.0 - do K=nzc,2,-1 - dist_from_bot = dist_from_bot + dz(k) - I_L2_bdry(K) = (dist_from_top(K) + dist_from_bot)**2 / & - (dist_from_top(K) * dist_from_bot)**2 - enddo + if (GV%Boussinesq) then + do K=1,nzc+1 ; dz_h_Int(K) = GV%H_to_Z ; enddo + else + ! Find an effective average specific volume around an interface. + dz_h_Int(1:nzc+1) = 0.0 + if (hlay(1) > 0.0) dz_h_Int(1) = dz_lay(1) / hlay(1) + do K=2,nzc+1 + if (h_Int(K) > 0.0) then + dz_h_Int(K) = dz_Int(K) / h_Int(K) + else + dz_h_Int(K) = dz_h_Int(K-1) + endif + enddo + endif ! Calculate thermodynamic coefficients and an initial estimate of N2. if (use_temperature) then pressure(1) = surface_pres do K=2,nzc - pressure(K) = pressure(K-1) + gR0*dz(k-1) + pressure(K) = pressure(K-1) + gR0*hlay(k-1) T_int(K) = 0.5*(T(k-1) + T(k)) Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) enddo - call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, & - tv%eqn_of_state, (/2,nzc/), scale=-g_R0 ) - else + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, & + tv%eqn_of_state, (/2,nzc/), scale=-g_R0 ) + else + ! These should perhaps be combined into a single call to calculate the thermal expansion + ! and haline contraction coefficients? + call calculate_specific_vol_derivs(T_int, Sal_int, pressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,nzc/) ) + call calculate_density(T_int, Sal_int, pressure, rho_int, tv%eqn_of_state, (/2,nzc/) ) + do K=2,nzc + dbuoy_dT(K) = (US%L_to_Z**2 * GV%g_Earth) * (rho_int(K) * dSpV_dT(K)) + dbuoy_dS(K) = (US%L_to_Z**2 * GV%g_Earth) * (rho_int(K) * dSpV_dS(K)) + enddo + endif + elseif (GV%Boussinesq .or. GV%semi_Boussinesq) then do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo + else + do K=1,nzc+1 ; dbuoy_dS(K) = 0.0 ; enddo + dbuoy_dT(1) = -(US%L_to_Z**2 * GV%g_Earth) / GV%Rlay(1) + do K=2,nzc + dbuoy_dT(K) = -(US%L_to_Z**2 * GV%g_Earth) / (0.5*(GV%Rlay(k-1) + GV%Rlay(k))) + enddo + dbuoy_dT(nzc+1) = -(US%L_to_Z**2 * GV%g_Earth) / GV%Rlay(nzc) endif ! N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 @@ -829,7 +914,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! enddo ! This call just calculates N2 and S2. - call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, hlay, I_dz_int, dbuoy_dT, dbuoy_dS, & CS%vel_underflow, u, v, T, Sal, N2, S2, GV, US) ! ---------------------------------------------------- ! Iterate @@ -840,8 +925,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & kappa_avg(K) = 0.0 ; tke_avg(K) = 0.0 local_src_avg(K) = 0.0 ! Use the grid spacings to scale errors in the source. - if ( dz_Int(K) > 0.0 ) & - local_src_avg(K) = 0.1 * k0dt * I_dz_int(K) / dz_Int(K) + if ( h_Int(K) > 0.0 ) & + local_src_avg(K) = 0.1 * k0dt * I_dz_int(K) / h_Int(K) enddo ! call cpu_clock_end(id_clock_setup) @@ -854,7 +939,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! ---------------------------------------------------- ! call cpu_clock_begin(id_clock_KQ) - call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & + call find_kappa_tke(N2, S2, kappa, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nzc, CS, GV, US, K_Q, tke, kappa_out, kappa_src, local_src) ! call cpu_clock_end(id_clock_KQ) @@ -892,7 +977,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! timestep is found long before the minimum is reached, so the ! value of max_KS_it may be unimportant, especially if it is large ! enough. - call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) valid_dt = .true. @@ -925,7 +1010,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & if ((dt_test < dt_rem) .and. valid_dt) then dt_inc = 0.5*dt_test do itt_dt=1,dt_refinements - call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*(dt_test+dt_inc), nzc, dz, & + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*(dt_test+dt_inc), nzc, hlay, & I_dz_int, dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, T_test, S_test, & N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) valid_dt = .true. @@ -974,14 +1059,14 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! call cpu_clock_end(id_clock_avg) else ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) ! call cpu_clock_end(id_clock_project) ! call cpu_clock_begin(id_clock_KQ) do K=1,nzc+1 ; K_Q_tmp(K) = K_Q(K) ; enddo - call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & + call find_kappa_tke(N2, S2, kappa_out, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nzc, CS, GV, US, K_Q_tmp, tke_pred, kappa_pred) ! call cpu_clock_end(id_clock_KQ) @@ -993,13 +1078,13 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & enddo ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) ! call cpu_clock_end(id_clock_project) ! call cpu_clock_begin(id_clock_KQ) - call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & + call find_kappa_tke(N2, S2, kappa_out, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nzc, CS, GV, US, K_Q, tke_pred, kappa_pred) ! call cpu_clock_end(id_clock_KQ) @@ -1017,7 +1102,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & if (dt_rem > 0.0) then ! Update the values of u, v, T, Sal, N2, and S2 for the next iteration. ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u, v, T, Sal, N2, S2, & GV, US) ! call cpu_clock_end(id_clock_project) @@ -1037,15 +1122,15 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int integer, intent(in) :: nz !< The number of layers (after eliminating massless !! layers?). real, dimension(nz+1), intent(in) :: kappa !< The diapycnal diffusivity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or Pa s]. real, dimension(nz), intent(in) :: u0 !< The initial zonal velocity [L T-1 ~> m s-1]. real, dimension(nz), intent(in) :: v0 !< The initial meridional velocity [L T-1 ~> m s-1]. real, dimension(nz), intent(in) :: T0 !< The initial temperature [C ~> degC]. real, dimension(nz), intent(in) :: S0 !< The initial salinity [S ~> ppt]. real, intent(in) :: dt !< The time step [T ~> s]. - real, dimension(nz), intent(in) :: dz !< The grid spacing of layers [Z ~> m]. - real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the layer's thicknesses - !! [Z-1 ~> m-1]. + real, dimension(nz), intent(in) :: dz !< The layer thicknesses [H ~> m or kg m-2] + real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the distance between succesive + !! layer centers [Z-1 ~> m-1]. real, dimension(nz+1), intent(in) :: dbuoy_dT !< The partial derivative of buoyancy with !! temperature [Z T-2 C-1 ~> m s-2 degC-1]. real, dimension(nz+1), intent(in) :: dbuoy_dS !< The partial derivative of buoyancy with @@ -1066,9 +1151,9 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int ! Local variables real, dimension(nz+1) :: c1 ! A tridiagonal variable [nondim] - real :: a_a, a_b ! Tridiagonal coupling coefficients [Z ~> m] - real :: b1, b1nz_0 ! Tridiagonal variables [Z-1 ~> m-1] - real :: bd1 ! A term in the denominator of b1 [Z ~> m] + real :: a_a, a_b ! Tridiagonal coupling coefficients [H ~> m or kg m-2] + real :: b1, b1nz_0 ! Tridiagonal variables [H-1 ~> m-1 or m2 kg-1] + real :: bd1 ! A term in the denominator of b1 [H ~> m or kg m-2] real :: d1 ! A tridiagonal variable [nondim] integer :: k, ks, ke @@ -1162,17 +1247,21 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int end subroutine calculate_projected_state !> This subroutine calculates new, consistent estimates of TKE and kappa. -subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & +subroutine find_kappa_tke(N2, S2, kappa_in, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nz, CS, GV, US, K_Q, tke, kappa, kappa_src, local_src) integer, intent(in) :: nz !< The number of layers to work on. real, dimension(nz+1), intent(in) :: N2 !< The buoyancy frequency squared at interfaces [T-2 ~> s-2]. real, dimension(nz+1), intent(in) :: S2 !< The squared shear at interfaces [T-2 ~> s-2]. real, dimension(nz+1), intent(in) :: kappa_in !< The initial guess at the diffusivity - !! [Z2 T-1 ~> m2 s-1]. - real, dimension(nz+1), intent(in) :: dz_Int !< The thicknesses associated with interfaces - !! [Z ~> m]. + !! [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(nz+1), intent(in) :: h_Int !< The thicknesses associated with interfaces + !! [H ~> m or kg m-2] + real, dimension(nz+1), intent(in) :: dz_Int !< The vertical distances around interfaces [Z ~> m] + real, dimension(nz+1), intent(in) :: dz_h_Int !< The ratio of the vertical distances to the + !! thickness around an interface [Z H-1 ~> nondim or m3 kg-1]. + !! In non-Boussinesq mode this is the specific volume. real, dimension(nz+1), intent(in) :: I_L2_bdry !< The inverse of the squared distance to - !! boundaries [Z-2 ~> m-2]. + !! boundaries [H-1 Z-1 ~> m-2 or m kg-1]. real, dimension(nz), intent(in) :: Idz !< The inverse grid spacing of layers [Z-1 ~> m-1]. real, intent(in) :: f2 !< The squared Coriolis parameter [T-2 ~> s-2]. type(Kappa_shear_CS), pointer :: CS !< A pointer to this module's control structure. @@ -1180,42 +1269,41 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(nz+1), intent(inout) :: K_Q !< The shear-driven diapycnal diffusivity divided by !! the turbulent kinetic energy per unit mass at - !! interfaces [T ~> s]. + !! interfaces [H T Z-1 ~> s or kg s m-3]. real, dimension(nz+1), intent(out) :: tke !< The turbulent kinetic energy per unit mass at !! interfaces [Z2 T-2 ~> m2 s-2]. - real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. + real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(nz+1), optional, & - intent(out) :: kappa_src !< The source term for kappa [T-1 ~> s-1]. + intent(out) :: kappa_src !< The source term for kappa [T-1 ~> s-1] real, dimension(nz+1), optional, & - intent(out) :: local_src !< The sum of all local sources for kappa, - !! [T-1 ~> s-1]. + intent(out) :: local_src !< The sum of all local sources for kappa + !! [T-1 ~> s-1] ! This subroutine calculates new, consistent estimates of TKE and kappa. ! Local variables real, dimension(nz) :: & - aQ, & ! aQ is the coupling between adjacent interfaces in the TKE equations [Z T-1 ~> m s-1]. + aQ, & ! aQ is the coupling between adjacent interfaces in the TKE equations [H T-1 ~> m s-1 or kg m-2 s-1] dQdz ! Half the partial derivative of TKE with depth [Z T-2 ~> m s-2]. real, dimension(nz+1) :: & - dK, & ! The change in kappa [Z2 T-1 ~> m2 s-1]. + dK, & ! The change in kappa [H Z T-1 ~> m2 s-1 or Pa s]. dQ, & ! The change in TKE [Z2 T-2 ~> m2 s-2]. cQ, cK, & ! cQ and cK are the upward influences in the tridiagonal and ! hexadiagonal solvers for the TKE and kappa equations [nondim]. - I_Ld2, & ! 1/Ld^2, where Ld is the effective decay length scale for kappa [Z-2 ~> m-2]. + I_Ld2, & ! 1/Ld^2, where Ld is the effective decay length scale for kappa [H-1 Z-1 ~> m-2 or m kg-1] TKE_decay, & ! The local TKE decay rate [T-1 ~> s-1]. k_src, & ! The source term in the kappa equation [T-1 ~> s-1]. - dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k) [T ~> s]. - dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k) [T-1 ~> s-1]. + dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k) [Z T H-1 ~> s or m3 s kg-1] + dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k) [H Z-1 T-1 ~> s-1 or kg m-3 s-1] e1 ! The fractional change in a layer TKE due to a change in the ! TKE of the layer above when all the kappas below are 0 [nondim]. ! e1 is nondimensional, and 0 < e1 < 1. - real :: tke_src ! The net source of TKE due to mixing against the shear - ! and stratification [Z2 T-3 ~> m2 s-3]. (For convenience, - ! a term involving the non-dissipation of q0 is also - ! included here.) - real :: bQ ! The inverse of the pivot in the tridiagonal equations [T Z-1 ~> s m-1]. + real :: tke_src ! The net source of TKE due to mixing against the shear and stratification + ! [Z2 T-3 ~> m2 s-3] or [H Z T-3 ~> m2 s-3 or kg m-1 s-3]. + ! (For convenience, a term involving the non-dissipation of q0 is also included here.) + real :: bQ ! The inverse of the pivot in the tridiagonal equations [T H-1 ~> s m-1 or m2 s kg-1] real :: bK ! The inverse of the pivot in the tridiagonal equations [Z-1 ~> m-1]. - real :: bQd1 ! A term in the denominator of bQ [Z T-1 ~> m s-1]. + real :: bQd1 ! A term in the denominator of bQ [H T-1 ~> m s-1 or kg m-2 s-1] real :: bKd1 ! A term in the denominator of bK [Z ~> m]. real :: cQcomp, cKcomp ! 1 - cQ or 1 - cK in the tridiagonal equations [nondim]. real :: c_s2 ! The coefficient for the decay of TKE due to @@ -1228,26 +1316,28 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & real :: Ilambda2 ! 1.0 / CS%lambda**2 [nondim] real :: TKE_min ! The minimum value of shear-driven TKE that can be ! solved for [Z2 T-2 ~> m2 s-2]. - real :: kappa0 ! The background diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0 [Z2 T-1 ~> m2 s-1]. + real :: kappa0 ! The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0 [H Z T-1 ~> m2 s-1 or Pa s] - real :: eden1, eden2 ! Variables used in calculating e1 [Z-1 ~> m-1] - real :: I_eden ! The inverse of the denominator in e1 [Z ~> m] + real :: eden1, eden2 ! Variables used in calculating e1 [H Z-2 ~> m-1 or kg m-4] + real :: I_eden ! The inverse of the denominator in e1 [Z2 H-1 ~> m or m4 kg-1] real :: ome ! Variables used in calculating e1 [nondim] - real :: diffusive_src ! The diffusive source in the kappa equation [Z T-1 ~> m s-1]. + real :: diffusive_src ! The diffusive source in the kappa equation [H T-1 ~> m s-1 or kg m-2 s-1] real :: chg_by_k0 ! The value of k_src that leads to an increase of - ! kappa_0 if only the diffusive term is a sink [T-1 ~> s-1]. + ! kappa_0 if only the diffusive term is a sink [T-1 ~> s-1] + real :: h_dz_here ! The ratio of the thicknesses to the vertical distances around an interface + ! [H Z-1 ~> nondim or kg m-3]. In non-Boussinesq mode this is the density. - real :: kappa_mean ! A mean value of kappa [Z2 T-1 ~> m2 s-1]. + real :: kappa_mean ! A mean value of kappa [H Z T-1 ~> m2 s-1 or Pa s] real :: Newton_test ! The value of relative error that will cause the next ! iteration to use Newton's method [nondim]. ! Temporary variables used in the Newton's method iterations. real :: decay_term_k ! The decay term in the diffusivity equation [Z-1 ~> m-1] - real :: decay_term_Q ! The decay term in the TKE equation - proportional to [T-1 ~> s-1] + real :: decay_term_Q ! The decay term in the TKE equation - proportional to [H Z-1 T-1 ~> s-1 or kg m-3 s-1] real :: I_Q ! The inverse of TKE [T2 Z-2 ~> s2 m-2] - real :: kap_src ! A source term in the kappa equation [Z T-1 ~> m s-1] - real :: v1 ! A temporary variable proportional to [T-1 ~> s-1] - real :: v2 ! A temporary variable in [Z T-2 ~> m s-2] + real :: kap_src ! A source term in the kappa equation [H T-1 ~> m s-1 or kg m-2 s-1] + real :: v1 ! A temporary variable proportional to [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + real :: v2 ! A temporary variable in [Z T-2 ~> m s-2] real :: tol_err ! The tolerance for max_err that determines when to ! stop iterating [nondim]. real :: Newton_err ! The tolerance for max_err that determines when to @@ -1271,11 +1361,11 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! These variables are used only for debugging. logical, parameter :: debug_soln = .false. - real :: K_err_lin ! The imbalance in the K equation [Z T-1 ~> m s-1] - real :: Q_err_lin ! The imbalance in the Q equation [Z2 T-3 ~> m2 s-3] + real :: K_err_lin ! The imbalance in the K equation [H T-1 ~> m s-1 or kg m-2 s-1] + real :: Q_err_lin ! The imbalance in the Q equation [H Z T-3 ~> m2 s-3 or kg m-1 s-3] 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]. + I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [H-1 Z-1 ~> m-2 or m kg-1]. + kappa_prev, & ! The value of kappa at the start of the current iteration [H Z T-1 ~> m2 s-1 or Pa s] TKE_prev ! The value of TKE at the start of the current iteration [Z2 T-2 ~> m2 s-2]. c_N2 = CS%C_N**2 ; c_S2 = CS%C_S**2 @@ -1333,14 +1423,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! k-1, the final changes in TKE are related by dQ(K+1) = e1(K+1)*dQ(K). eden2 = kappa0 * Idz(nz) if (tke_noflux_bottom_BC) then - eden1 = dz_Int(nz+1)*TKE_decay(nz+1) + eden1 = h_Int(nz+1)*TKE_decay(nz+1) I_eden = 1.0 / (eden2 + eden1) e1(nz+1) = eden2 * I_eden ; ome = eden1 * I_eden else e1(nz+1) = 0.0 ; ome = 1.0 endif do k=nz,2,-1 - eden1 = dz_Int(K)*TKE_decay(K) + ome * eden2 + eden1 = h_Int(K)*TKE_decay(K) + ome * eden2 eden2 = kappa0 * Idz(k-1) I_eden = 1.0 / (eden2 + eden1) e1(K) = eden2 * I_eden ; ome = eden1 * I_eden ! = 1-e1 @@ -1370,20 +1460,20 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & enddo dQ(1) = -TKE(1) if (tke_noflux_top_BC) then - tke_src = kappa0*S2(1) + q0 * TKE_decay(1) ! Uses that kappa(1) = 0 - bQd1 = dz_Int(1) * TKE_decay(1) + tke_src = dz_h_Int(1)*kappa0*S2(1) + q0 * TKE_decay(1) ! Uses that kappa(1) = 0 + bQd1 = h_Int(1) * TKE_decay(1) bQ = 1.0 / (bQd1 + aQ(1)) - tke(1) = bQ * (dz_Int(1)*tke_src) + tke(1) = bQ * (h_Int(1)*tke_src) cQ(2) = aQ(1) * bQ ; cQcomp = bQd1 * bQ ! = 1 - cQ else tke(1) = q0 ; cQ(2) = 0.0 ; cQcomp = 1.0 endif do K=2,ke_tke-1 dQ(K) = -TKE(K) - tke_src = (kappa(K) + kappa0)*S2(K) + q0*TKE_decay(K) - bQd1 = dz_Int(K)*(TKE_decay(K) + N2(K)*K_Q(K)) + cQcomp*aQ(k-1) + tke_src = dz_h_Int(K)*(kappa(K) + kappa0)*S2(K) + q0*TKE_decay(K) + bQd1 = h_Int(K)*(TKE_decay(K) + dz_h_Int(K)*N2(K)*K_Q(K)) + cQcomp*aQ(k-1) bQ = 1.0 / (bQd1 + aQ(k)) - tke(K) = bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + tke(K) = bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1)) cQ(K+1) = aQ(k) * bQ ; cQcomp = bQd1 * bQ ! = 1 - cQ enddo if ((ke_tke == nz+1) .and. .not.(tke_noflux_bottom_BC)) then @@ -1391,18 +1481,18 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dQ(nz+1) = 0.0 else k = ke_tke - tke_src = kappa0*S2(K) + q0*TKE_decay(K) ! Uses that kappa(ke_tke) = 0 + tke_src = dz_h_Int(K)*kappa0*S2(K) + q0*TKE_decay(K) ! Uses that kappa(ke_tke) = 0 if (K == nz+1) then dQ(K) = -TKE(K) - bQ = 1.0 / (dz_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) - tke(K) = max(TKE_min, bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1))) + bQ = 1.0 / (h_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + tke(K) = max(TKE_min, bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1))) dQ(K) = tke(K) + dQ(K) else - bQ = 1.0 / ((dz_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + aQ(k)) + bQ = 1.0 / ((h_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + aQ(k)) cQ(K+1) = aQ(k) * bQ ! Account for all changes deeper in the water column. dQ(K) = -TKE(K) - tke(K) = max((bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + & + tke(K) = max((bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + & cQ(K+1)*(tke(K+1) - e1(K+1)*tke(K))) / (1.0 - cQ(K+1)*e1(K+1)), TKE_min) dQ(K) = tke(K) + dQ(K) @@ -1432,17 +1522,17 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(1) = 0.0 ! kappa takes boundary values of 0. cK(2) = 0.0 ; cKcomp = 1.0 - if (itt == 1) then ; dO K=2,nz - I_Ld2(K) = (N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + if (itt == 1) then ; do K=2,nz + I_Ld2(K) = dz_h_Int(K)*(N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) enddo ; endif do K=2,nz dK(K) = -kappa(K) if (itt>1) & - I_Ld2(K) = (N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) - bKd1 = dz_Int(K)*I_Ld2(K) + cKcomp*Idz(k-1) + I_Ld2(K) = dz_h_Int(K)*(N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + bKd1 = h_Int(K)*I_Ld2(K) + cKcomp*Idz(k-1) bK = 1.0 / (bKd1 + Idz(k)) - kappa(K) = bK * (Idz(k-1)*kappa(K-1) + dz_Int(K) * K_src(K)) + kappa(K) = bK * (Idz(k-1)*kappa(K-1) + h_Int(K) * K_src(K)) cK(K+1) = Idz(k) * bK ; cKcomp = bKd1 * bK ! = 1 - cK(K+1) ! Neglect values that are smaller than kappa_trunc. @@ -1482,12 +1572,12 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & aQ(1) = (0.5*(kappa(1)+kappa(2))+kappa0) * Idz(1) dQdz(1) = 0.5*(TKE(1) - TKE(2))*Idz(1) if (tke_noflux_top_BC) then - tke_src = dz_Int(1) * (kappa0*S2(1) - (TKE(1) - q0)*TKE_decay(1)) - & + tke_src = h_Int(1) * (kappa0*dz_h_Int(1)*S2(1) - (TKE(1) - q0)*TKE_decay(1)) - & aQ(1) * (TKE(1) - TKE(2)) - bQ = 1.0 / (aQ(1) + dz_Int(1)*TKE_decay(1)) + bQ = 1.0 / (aQ(1) + h_Int(1)*TKE_decay(1)) cQ(2) = aQ(1) * bQ - cQcomp = (dz_Int(1)*TKE_decay(1)) * bQ ! = 1 - cQ(2) + cQcomp = (h_Int(1)*TKE_decay(1)) * bQ ! = 1 - cQ(2) dQmdK(2) = -dQdz(1) * bQ dQ(1) = bQ * tke_src else @@ -1495,14 +1585,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & endif do K=2,nz I_Q = 1.0 / TKE(K) - I_Ld2(K) = (N2(K)*Ilambda2 + f2) * I_Q + I_L2_bdry(K) + I_Ld2(K) = (N2(K)*Ilambda2 + f2) * dz_h_Int(K)*I_Q + I_L2_bdry(K) - kap_src = dz_Int(K) * (K_src(K) - I_Ld2(K)*kappa(K)) + & + kap_src = h_Int(K) * (K_src(K) - I_Ld2(K)*kappa(K)) + & Idz(k-1)*(kappa(K-1)-kappa(K)) - Idz(k)*(kappa(K)-kappa(K+1)) ! Ensure that the pivot is always positive, and that 0 <= cK <= 1. ! Otherwise do not use Newton's method. - decay_term_k = -Idz(k-1)*dQmdK(K)*dKdQ(K-1) + dz_Int(K)*I_Ld2(K) + decay_term_k = -Idz(k-1)*dQmdK(K)*dKdQ(K-1) + h_Int(K)*I_Ld2(K) if (decay_term_k < 0.0) then ; abort_Newton = .true. ; exit ; endif bK = 1.0 / (Idz(k) + Idz(k-1)*cKcomp + decay_term_k) @@ -1528,8 +1618,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Solve for dQ(K)... aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) dQdz(k) = 0.5*(TKE(K) - TKE(K+1))*Idz(k) - tke_src = dz_Int(K) * (((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & - (TKE(k) - q0)*TKE_decay(k)) - & + tke_src = h_Int(K) * (dz_h_Int(K)*((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & + (TKE(k) - q0)*TKE_decay(k)) - & (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) v2 = (v1*dQmdK(K) + dQdz(k-1)*cK(K)) + & @@ -1537,7 +1627,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Ensure that the pivot is always positive, and that 0 <= cQ <= 1. ! Otherwise do not use Newton's method. - decay_term_Q = dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K) - v2*dKdQ(K) + decay_term_Q = h_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K) - v2*dKdQ(K) if (decay_term_Q < 0.0) then ; abort_Newton = .true. ; exit ; endif bQ = 1.0 / (aQ(k) + (cQcomp*aQ(k-1) + decay_term_Q)) @@ -1560,11 +1650,11 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(nz+1) = 0.0 ; dKdQ(nz+1) = 0.0 if (tke_noflux_bottom_BC) then K = nz+1 - tke_src = dz_Int(K) * (kappa0*S2(K) - (TKE(K) - q0)*TKE_decay(K)) + & + tke_src = h_Int(K) * (kappa0*dz_h_Int(K)*S2(K) - (TKE(K) - q0)*TKE_decay(K)) + & aQ(k-1) * (TKE(K-1) - TKE(K)) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) - decay_term_Q = max(0.0, dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K)) + decay_term_Q = max(0.0, h_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K)) if (decay_term_Q < 0.0) then abort_Newton = .true. else @@ -1584,9 +1674,9 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & 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)) - & + ! tke_src_norm = ((kappa0*dz_Int(K)*S2(K) - h_Int(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))) + ! (aQ(k) + (aQ(k-1) + h_Int(K)*TKE_decay(K))) endif dK(K) = 0.0 ! Ensure that TKE+dQ will not drop below 0.5*TKE. @@ -1625,23 +1715,24 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! The unit conversions here have not been carefully tested. 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 + ! compared with the dominant terms, perhaps, h_Int*I_Ld2*kappa and + ! h_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been ! been increased to ensure a positive pivot, or 2) negative TKEs have been ! truncated, or 3) small or negative kappas have been rounded toward 0. I_Q = 1.0 / TKE(K) - I_Ld2_debug(K) = (N2(K)*Ilambda2 + f2) * I_Q + I_L2_bdry(K) + I_Ld2_debug(K) = (N2(K)*Ilambda2 + f2) * dz_h_Int(K)*I_Q + I_L2_bdry(K) - kap_src = dz_Int(K) * (K_src(K) - I_Ld2(K)*kappa_prev(K)) + & + kap_src = h_Int(K) * (k_src(K) - I_Ld2(K)*kappa_prev(K)) + & (Idz(k-1)*(kappa_prev(k-1)-kappa_prev(k)) - & Idz(k)*(kappa_prev(k)-kappa_prev(k+1))) K_err_lin = -Idz(k-1)*(dK(K-1)-dK(K)) + Idz(k)*(dK(K)-dK(K+1)) + & - dz_Int(K)*I_Ld2_debug(K)*dK(K) - kap_src - & + h_Int(K)*I_Ld2_debug(K)*dK(K) - kap_src - & dz_Int(K)*(N2(K)*Ilambda2 + f2)*I_Q**2*kappa_prev(K) * dQ(K) - tke_src = dz_Int(K) * ((kappa_prev(K) + kappa0)*S2(K) - & - kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*TKE_decay(K)) - & - (aQ(k) * (TKE_prev(K) - TKE_prev(K+1)) - aQ(k-1) * (TKE_prev(K-1) - TKE_prev(K))) + h_dz_here = 0.0 ; if (abs(dz_h_Int(K)) > 0.0) h_dz_here = 1.0 / dz_h_Int(K) + tke_src = h_Int(K) * ((kappa_prev(K) + kappa0)*S2(K) - & + kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*h_dz_here*TKE_decay(K)) - & + (aQ(k) * (TKE_prev(K) - TKE_prev(K+1)) - aQ(k-1) * (TKE_prev(K-1) - TKE_prev(K))) Q_err_lin = tke_src + (aQ(k-1) * (dQ(K-1)-dQ(K)) - aQ(k) * (dQ(k)-dQ(k+1))) - & 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)) + & @@ -1701,11 +1792,11 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & local_src(1) = 0.0 ; local_src(nz+1) = 0.0 do K=2,nz diffusive_src = Idz(k-1)*(kappa(K-1)-kappa(K)) + Idz(k)*(kappa(K+1)-kappa(K)) - chg_by_k0 = kappa0 * ((Idz(k-1)+Idz(k)) / dz_Int(K) + I_Ld2(K)) + chg_by_k0 = kappa0 * ((Idz(k-1)+Idz(k)) / h_Int(K) + I_Ld2(K)) if (diffusive_src <= 0.0) then local_src(K) = K_src(K) + chg_by_k0 else - local_src(K) = (K_src(K) + chg_by_k0) + diffusive_src / dz_Int(K) + local_src(K) = (K_src(K) + chg_by_k0) + diffusive_src / h_Int(K) endif enddo endif @@ -1790,17 +1881,17 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "The background diffusivity that is used to smooth the "//& "density and shear profiles before solving for the "//& "diffusivities. The default is the greater of KD and 1e-7 m2 s-1.", & - units="m2 s-1", default=kappa_0_default*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, & + units="m2 s-1", default=kappa_0_default*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, & do_not_log=just_read) call get_param(param_file, mdl, "KD_SEED_KAPPA_SHEAR", CS%kappa_seed, & "A moderately large seed value of diapycnal diffusivity that is used as a "//& "starting turbulent diffusivity in the iterations to find an energetically "//& "constrained solution for the shear-driven diffusivity.", & - units="m2 s-1", default=1.0, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KD_TRUNC_KAPPA_SHEAR", CS%kappa_trunc, & "The value of shear-driven diffusivity that is considered negligible "//& "and is rounded down to 0. The default is 1% of KD_KAPPA_SHEAR_0.", & - units="m2 s-1", default=0.01*CS%kappa_0*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, & + units="m2 s-1", default=0.01*CS%kappa_0*GV%HZ_T_to_m2_s, scale=GV%m2_s_to_HZ_T, & do_not_log=just_read) call get_param(param_file, mdl, "FRI_CURVATURE", CS%FRi_curvature, & "The nondimensional curvature of the function of the "//& From bd5fe0c2ca70b2226dd3bbae7f611ec364ed2063 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 14 May 2023 12:39:38 -0400 Subject: [PATCH 066/146] +(*)Use tv%SpV in MOM_sponge code Use tv%SpV convert thicknesses to vertical distances in apply_sponge when it is allocated to replace multiplication by GV%H_to_Z, thereby eliminating the dependence on GV%RHo_0 in this modue in non-Boussinesq mode. The new internal array dz_to_h is used to reduce the code duplication as a result of these changes. All answers in Boussinesq test cases are bitwise identical, but answers change in fully non-Boussinesq mode. In semi-Boussinesq mode answers are mathematically equivalent but change at roundoff unless RHO_0 is an integer power of 2. --- src/parameterizations/vertical/MOM_sponge.F90 | 76 ++++++++++++++----- 1 file changed, 58 insertions(+), 18 deletions(-) diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index fce1eb493d..4bdf610a24 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -347,10 +347,14 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) ! give 0 at the surface [nondim]. real :: e(SZK_(GV)+1) ! The interface heights [Z ~> m], usually negative. + real :: dz_to_h(SZK_(GV)+1) ! Factors used to convert interface height movement + ! to thickness fluxes [H Z-1 ~> nondim or kg m-3] real :: e0 ! The height of the free surface [Z ~> m]. real :: e_str ! A nondimensional amount by which the reference ! profile must be stretched for the free surfaces ! heights in the two profiles to agree [nondim]. + real :: w_mean ! The vertical displacement of water moving upward through an + ! interface within 1 timestep [Z ~> m]. real :: w ! The thickness of water moving upward through an ! interface within 1 timestep [H ~> m or kg m-2]. real :: wm ! wm is w if w is negative and 0 otherwise [H ~> m or kg m-2]. @@ -384,9 +388,15 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) "work properly with i-mean sponges and a bulk mixed layer.") do j=js,je ; do i=is,ie ; e_D(i,j,nz+1) = -G%bathyT(i,j) ; enddo ; enddo - do k=nz,1,-1 ; do j=js,je ; do i=is,ie - e_D(i,j,K) = e_D(i,j,K+1) + h(i,j,k)*GV%H_to_Z - enddo ; enddo ; enddo + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + e_D(i,j,K) = e_D(i,j,K+1) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo ; enddo + else + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + e_D(i,j,K) = e_D(i,j,K+1) + h(i,j,k)*GV%H_to_Z + enddo ; enddo ; enddo + endif do j=js,je do i=is,ie dilate(i) = (G%bathyT(i,j) + G%Z_ref) / (e_D(i,j,1) + G%bathyT(i,j)) @@ -424,20 +434,39 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) do K=2,nz+1 ; do i=is,ie h_above(i,K) = h_above(i,K-1) + max(h(i,j,k-1)-GV%Angstrom_H, 0.0) enddo ; enddo - do K=2,nz - ! w is positive for an upward (lightward) flux of mass, resulting - ! in the downward movement of an interface. - w = damp_1pdamp * eta_mean_anom(j,K) * GV%Z_to_H - do i=is,ie + + ! In both blocks below, w is positive for an upward (lightward) flux of mass, + ! resulting in the downward movement of an interface. + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do K=2,nz + w_mean = damp_1pdamp * eta_mean_anom(j,K) + do i=is,ie + w = w_mean * 2.0*GV%RZ_to_H / (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) + if (w > 0.0) then + w_int(i,j,K) = min(w, h_below(i,K)) + eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + else + w_int(i,j,K) = max(w, -h_above(i,K)) + ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + endif + enddo + enddo + else + do K=2,nz + w = damp_1pdamp * eta_mean_anom(j,K) * GV%Z_to_H if (w > 0.0) then - w_int(i,j,K) = min(w, h_below(i,K)) - eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + do i=is,ie + w_int(i,j,K) = min(w, h_below(i,K)) + eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + enddo else - w_int(i,j,K) = max(w, -h_above(i,K)) - ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + do i=is,ie + w_int(i,j,K) = max(w, -h_above(i,K)) + ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + enddo endif enddo - enddo + endif do k=1,nz ; do i=is,ie ea_k = max(0.0, -w_int(i,j,K)) eb_k = max(0.0, w_int(i,j,K+1)) @@ -462,9 +491,20 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) damp = dt * CS%Iresttime_col(c) e(1) = 0.0 ; e0 = 0.0 - do K=1,nz - e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z - enddo + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do K=1,nz + e(K+1) = e(K) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo + dz_to_h(1) = GV%RZ_to_H / tv%SpV_avg(i,j,1) + do K=2,nz + dz_to_h(K) = 2.0*GV%RZ_to_H / (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) + enddo + else + do K=1,nz + e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z + dz_to_h(K) = GV%Z_to_H + enddo + endif e_str = e(nz+1) / CS%Ref_eta(nz+1,c) if ( CS%bulkmixedlayer ) then @@ -481,7 +521,7 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) wpb = 0.0; wb = 0.0 do k=nz,nkmb+1,-1 if (GV%Rlay(k) > Rcv_ml(i,j)) then - w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*dz_to_h(K), & ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w-ABS(w)) do m=1,CS%fldno @@ -537,7 +577,7 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) wpb = 0.0 wb = 0.0 do k=nz,1,-1 - w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*dz_to_h(K), & ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w - ABS(w)) do m=1,CS%fldno From b3c7331c9ee9306d334cd4a1ea6127fe00c4ccb5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Jul 2023 09:49:08 -0400 Subject: [PATCH 067/146] *Non-Boussinesq expressions for DOME inflow rates Set DOME inflow properties using the average density rather than RHO_0 when in non-Boussinesq mode. The existing Boussinesq solutions are unchanged, but this changes the non-Boussinesq DOME solutions, which no longer depend on the Boussinesq reference density. --- src/user/DOME_initialization.F90 | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 4a12387d9d..638ecf80db 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -322,6 +322,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) real :: D_edge ! The thickness [Z ~> m] of the dense fluid at the ! inner edge of the inflow real :: RLay_range ! The range of densities [R ~> kg m-3]. + real :: Rlay_Ref ! The surface layer's target density [R ~> kg m-3]. real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] real :: f_inflow ! The value of the Coriolis parameter used to determine DOME inflow ! properties [T-1 ~> s-1] @@ -351,6 +352,9 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) call get_param(PF, mdl, "DENSITY_RANGE", Rlay_range, & "The range of reference potential densities in the layers.", & units="kg m-3", default=2.0, scale=US%kg_m3_to_R) + call get_param(PF, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) call get_param(PF, mdl, "F_0", f_0, & "The reference value of the Coriolis parameter with the betaplane option.", & units="s-1", default=0.0, scale=US%T_to_s) @@ -369,9 +373,15 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) if (.not.associated(OBC)) return - g_prime_tot = (GV%g_Earth / GV%Rho0) * Rlay_range - Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) - tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * GV%Z_to_H + if (GV%Boussinesq) then + g_prime_tot = (GV%g_Earth / GV%Rho0) * Rlay_range + Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * GV%Z_to_H + else + g_prime_tot = (GV%g_Earth / (Rlay_Ref + 0.5*Rlay_range)) * Rlay_range + Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * (Rlay_Ref + 0.5*Rlay_range) * GV%RZ_to_H + endif I_Def_Rad = 1.0 / (1.0e-3*US%L_to_m*Def_Rad) From 32b5e8aee9185de8d9b055398e79b591d332064f Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 9 Mar 2023 15:12:18 -0500 Subject: [PATCH 068/146] Separate SAL from tidal_forcing Calculation for self-attraction and loading (SAL) is separated as a new module (MOM_self_attr_load) from module MOM_tidal_forcing, as SAL is a process not limited to tides. The new module includes both online spherical harmonics method and scalar approximation. Read-in method (TIDAL_SAL_FROM_FILE) is kept in the tidal forcing module as it is specific to tides. For the iterative method (USE_PREV_TIDES), the updating part that is tied to the scalar approximation is moved to the new SAL model, while the read-in part remains in the tidal_forcing module. The tidal forcing module now only contains calculations independent from the ocean's state and the only input variables is the current time. * A new parameter CALCULATE_SAL is added, which controls SAL calculation in PressureForce independent of whether tides is on or not. The default of CALCULATE_SAL is TIDES to avoid making changes in old MOM_input. * For the unplit mode, runtime parameters calculate_SAL and use_tides are moved from init subroutines to control structures. This allows safe deallocations of the corresponding module CSs. * A new control structure for the SAL module is used by the dynamical cores and pressure force modules. * For SAL related parameters, their names still incorrectly contain TIDE or TIDAL. This will be addressed in the following commits. * A new diagnostic is added in PressureForce to output calculated SAL fields. Note that the 'e_tidal' diagnostic is unchanged and still includes SAL field for backward compatibility. * Subroutine tidal_forcing_sensitivity, which is used by the barotropic solver to take into account the scalar approximation, is renamed to scalar_SAL_sensitivity. * Documentations are updated for the cited papers. --- src/core/MOM_PressureForce.F90 | 10 +- src/core/MOM_PressureForce_FV.F90 | 81 ++++-- src/core/MOM_PressureForce_Montgomery.F90 | 70 +++-- src/core/MOM_barotropic.F90 | 34 ++- src/core/MOM_dynamics_split_RK2.F90 | 13 +- src/core/MOM_dynamics_unsplit.F90 | 20 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 20 +- .../lateral/MOM_load_love_numbers.F90 | 24 +- .../lateral/MOM_self_attr_load.F90 | 271 ++++++++++++++++++ .../lateral/MOM_spherical_harmonics.F90 | 16 +- .../lateral/MOM_tidal_forcing.F90 | 215 ++------------ 11 files changed, 491 insertions(+), 283 deletions(-) create mode 100644 src/parameterizations/lateral/MOM_self_attr_load.F90 diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 844d9db4bc..ad76a9a9f5 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -13,6 +13,7 @@ module MOM_PressureForce use MOM_PressureForce_Mont, only : PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss use MOM_PressureForce_Mont, only : PressureForce_Mont_init use MOM_PressureForce_Mont, only : PressureForce_Mont_CS +use MOM_self_attr_load, only : SAL_CS use MOM_tidal_forcing, only : tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -80,7 +81,7 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e end subroutine Pressureforce !> Initialize the pressure force control structure -subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, 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 @@ -88,7 +89,8 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_CS), intent(inout) :: CS !< Pressure force control structure - type(tidal_forcing_CS), intent(inout), optional :: tides_CSp !< Tide control structure + type(SAL_CS), intent(in), optional :: SAL_CSp !< SAL control structure + type(tidal_forcing_CS), intent(in), optional :: tides_CSp !< Tide control structure #include "version_variable.h" character(len=40) :: mdl = "MOM_PressureForce" ! This module's name. @@ -103,10 +105,10 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) if (CS%Analytic_FV_PGF) then call PressureForce_FV_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_FV, tides_CSp) + CS%PressureForce_FV, SAL_CSp, tides_CSp) else call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_Mont, tides_CSp) + CS%PressureForce_Mont, SAL_CSp, tides_CSp) endif end subroutine PressureForce_init diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 281623ae84..27a4e3ae5a 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -9,6 +9,7 @@ module MOM_PressureForce_FV use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_PressureForce_Mont, only : set_pbce_Bouss, set_pbce_nonBouss +use MOM_self_attr_load, only : calc_SAL, SAL_CS use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -35,6 +36,7 @@ module MOM_PressureForce_FV !> Finite volume pressure gradient control structure type, public :: PressureForce_FV_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq !! approximation [R ~> kg m-3]. @@ -61,9 +63,11 @@ module MOM_PressureForce_FV logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF integer :: id_e_tidal = -1 !< Diagnostic identifier + integer :: id_e_sal = -1 !< Diagnostic identifier integer :: id_rho_pgf = -1 !< Diagnostic identifier integer :: id_rho_stanley_pgf = -1 !< Diagnostic identifier integer :: id_p_stanley = -1 !< Diagnostic identifier + type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure end type PressureForce_FV_CS @@ -115,8 +119,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ real, dimension(SZI_(G),SZJ_(G)) :: & dp, & ! The (positive) change in pressure across a layer [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tidal, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources + ! and harmonic self-attraction and loading specific to tides [Z ~> m]. dM, & ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the @@ -301,16 +306,33 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo enddo + ! The following two if-statements are arranged in a way that answers are not + ! changed from old versions in which SAL is part of the tidal forcing module. + if (CS%calculate_SAL) then + ! Find and add the self-attraction and loading geopotential anomaly. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref + enddo ; enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo + endif + if (CS%tides) then ! Find and add the tidal geopotential anomaly. + call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref + za(i,j) = za(i,j) - GV%g_Earth * (e_sal(i,j) + e_tidal(i,j)) enddo ; enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_tidal(i,j) + za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) enddo ; enddo endif @@ -408,7 +430,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif endif - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) end subroutine PressureForce_FV_nonBouss @@ -441,8 +465,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in depth units [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: & - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tidal, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources + ! and harmonic self-attraction and loading specific to tides [Z ~> m]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. @@ -524,7 +549,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm G_Rho0 = GV%g_Earth / GV%Rho0 rho_ref = CS%Rho0 - if (CS%tides) then + ! The following two if-statements are arranged in a way that answers are not + ! changed from old versions in which SAL is part of the tidal forcing module. + if (CS%calculate_SAL) then ! Determine the surface height anomaly for calculating self attraction ! and loading. This should really be based on bottom pressure anomalies, ! but that is not yet implemented, and the current form is correct for @@ -538,21 +565,27 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo endif -! Here layer interface heights, e, are calculated. if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) + e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tidal(i,j))) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -G%bathyT(i,j) + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) enddo ; enddo endif + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1 e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z @@ -750,12 +783,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! what is used for eta in btstep. See how e was calculated about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j) + e_tidal(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + eta(i,j) = (e(i,j,1) + e_sal(i,j))*GV%Z_to_H enddo ; enddo endif endif @@ -797,12 +830,17 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif endif - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_rho_pgf>0) call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) + if (CS%id_rho_stanley_pgf>0) call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) + if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) end subroutine PressureForce_FV_Bouss !> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, 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 @@ -810,6 +848,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_FV_CS), intent(inout) :: CS !< Finite volume PGF control structure + type(SAL_CS), intent(in), target, optional :: SAL_CSp !< SAL control structure type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure ! Local variables @@ -824,6 +863,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS CS%diag => diag ; CS%Time => Time if (present(tides_CSp)) & CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) & + CS%SAL_CSp => SAL_CSp mdl = "MOM_PressureForce_FV" call log_version(param_file, mdl, version, "") @@ -834,6 +875,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%tides) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) @@ -878,6 +921,10 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS CS%id_p_stanley = register_diag_field('ocean_model', 'p_stanley', diag%axesTL, & Time, 'p in PGF with Stanley correction', 'Pa', conversion=US%RL2_T2_to_Pa) endif + if (CS%calculate_SAL) then + CS%id_e_sal = register_diag_field('ocean_model', 'e_SAL', diag%axesT1, & + Time, 'Self-attraction and loading height Anomaly', 'meter', conversion=US%Z_to_m) + endif 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) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 424e9b1a32..5223afbccb 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -9,6 +9,7 @@ module MOM_PressureForce_Mont use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_self_attr_load, only : calc_SAL, SAL_CS use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -31,6 +32,7 @@ module MOM_PressureForce_Mont !> Control structure for the Montgomery potential form of pressure gradient type, public :: PressureForce_Mont_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq !! approximation [R ~> kg m-3]. @@ -45,8 +47,9 @@ module MOM_PressureForce_Mont real, allocatable :: PFv_bc(:,:,:) !< Meridional accelerations due to pressure gradients !! deriving from density gradients within layers [L T-2 ~> m s-2]. !>@{ Diagnostic IDs - integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1 + integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1, id_e_sal = -1 !>@} + type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< The tidal forcing control structure end type PressureForce_Mont_CS @@ -103,8 +106,9 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! of a reduced gravity form of the equations [L2 T-2 ~> m2 s-2]. dp_star, & ! Layer thickness after compensation for compressibility [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. - e_tidal, & ! Bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. + e_sal, & ! Bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tidal, & ! Bottom geopotential anomaly due to tidal forces from astronomical sources + ! and harmonic self-attraction and loading specific to tides [Z ~> m]. geopot_bot ! Bottom geopotential relative to a temporally fixed reference value, ! including any tidal contributions [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate @@ -180,7 +184,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif endif - if (CS%tides) then + if (CS%calculate_SAL) then ! Determine the sea surface height anomalies, to enable the calculation ! of self-attraction and loading. !$OMP parallel do default(shared) @@ -203,16 +207,23 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb SSH(i,j) = SSH(i,j) + GV%H_to_RZ * h(i,j,k) * alpha_Lay(k) enddo ; enddo ; enddo endif + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo + endif - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*(e_tidal(i,j) + G%bathyT(i,j)) + geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + e_tidal(i,j) + G%bathyT(i,j)) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*G%bathyT(i,j) + geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + G%bathyT(i,j)) enddo ; enddo endif @@ -348,7 +359,9 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) end subroutine PressureForce_Mont_nonBouss @@ -396,9 +409,9 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, real :: h_star(SZI_(G),SZJ_(G)) ! Layer thickness after compensation ! for compressibility [Z ~> m]. real :: SSH(SZI_(G),SZJ_(G)) ! The sea surface height anomaly, in depth units [Z ~> m]. - real :: e_tidal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal - ! forces from astronomical sources and self- - ! attraction and loading, in depth units [Z ~> m]. + real :: e_sal(SZI_(G),SZJ_(G)) ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + real :: e_tidal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal forces from astronomical sources + ! and harmonic self-attraction and loading specific to tides, in depth units [Z ~> m]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). real :: I_Rho0 ! 1/Rho0 [R-1 ~> m3 kg-1]. @@ -440,7 +453,8 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, I_Rho0 = 1.0/CS%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 - if (CS%tides) then + + if (CS%calculate_SAL) then ! Determine the surface height anomaly for calculating self attraction ! and loading. This should really be based on bottom pressure anomalies, ! but that is not yet implemented, and the current form is correct for @@ -452,21 +466,26 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo endif -! Here layer interface heights, e, are calculated. if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) + e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tidal(i,j))) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -G%bathyT(i,j) + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) enddo ; enddo endif + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1 e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z @@ -588,19 +607,21 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j)+e_tidal(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + e_sal(i,j)*GV%Z_to_H enddo ; enddo endif endif if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) end subroutine PressureForce_Mont_Bouss @@ -821,7 +842,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) end subroutine Set_pbce_nonBouss !> Initialize the Montgomery-potential form of PGF control structure -subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, 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 @@ -829,6 +850,7 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_Mont_CS), intent(inout) :: CS !< Montgomery PGF control structure + type(SAL_CS), intent(in), target, optional :: SAL_CSp !< SAL control structure type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure ! Local variables @@ -841,6 +863,8 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ CS%diag => diag ; CS%Time => Time if (present(tides_CSp)) & CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) & + CS%SAL_CSp => SAL_CSp mdl = "MOM_PressureForce_Mont" call log_version(param_file, mdl, version, "") @@ -852,6 +876,8 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%tides) call get_param(param_file, mdl, "USE_EOS", use_EOS, default=.true., & do_not_log=.true.) ! Input for diagnostic use only. @@ -866,6 +892,10 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ allocate(CS%PFv_bc(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.) endif + if (CS%calculate_SAL) then + CS%id_e_sal = register_diag_field('ocean_model', 'e_SAL', diag%axesT1, & + Time, 'SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + endif 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) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index adbbd3b4dd..c814c563e3 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -23,7 +23,8 @@ module MOM_barotropic use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type use MOM_restart, only : register_restart_field, register_restart_pair use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_tidal_forcing, only : tidal_forcing_sensitivity, tidal_forcing_CS +use MOM_self_attr_load, only : scalar_SAL_sensitivity +use MOM_self_attr_load, only : SAL_CS use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type @@ -229,7 +230,7 @@ module MOM_barotropic real :: const_dyn_psurf !< The constant that scales the dynamic surface !! pressure [nondim]. Stable values are < ~1.0. !! The default is 0.9. - logical :: tides !< If true, apply tidal momentum forcing. + logical :: calculate_SAL !< If true, calculate self-attration and loading. logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the !! barotropic solver has the wrong sign, replicating a long-standing !! bug. @@ -283,7 +284,7 @@ module MOM_barotropic !! the timing of diagnostic output. type(MOM_domain_type), pointer :: BT_Domain => NULL() !< Barotropic MOM domain type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Control structure for tides + type(SAL_CS), pointer :: SAL_CSp => NULL() !< Control structure for SAL logical :: module_is_initialized = .false. !< If true, module has been initialized integer :: isdw !< The lower i-memory limit for the wide halo arrays. @@ -1088,8 +1089,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo endif - if (CS%tides) then - call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + if (CS%calculate_SAL) then + call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) if (CS%tidal_sal_bug) then dgeo_de = 1.0 + det_de + CS%G_extra else @@ -2845,7 +2846,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) endif det_de = 0.0 - if (CS%tides) call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + if (CS%calculate_SAL) call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) if (CS%tidal_sal_bug) then dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) else @@ -4297,7 +4298,7 @@ end subroutine bt_mass_source !! barotropic calculation and initializes any barotropic fields that have not !! already been initialized. subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, & - restart_CS, calc_dtbt, BT_cont, tides_CSp) + restart_CS, calc_dtbt, BT_cont, SAL_CSp) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -4321,8 +4322,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, type(BT_cont_type), pointer :: BT_cont !< A structure with elements that describe the !! effective open face areas as a function of !! barotropic flow. - type(tidal_forcing_CS), target, optional :: tides_CSp !< A pointer to the control structure of the - !! tide module. + type(SAL_CS), target, optional :: SAL_CSp !< A pointer to the control structure of the + !! SAL module. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -4348,7 +4349,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, real :: Z_to_H ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3] real :: H_to_Z ! A local unit conversion factor [Z H-1 ~> nondim or m3 kg-1] real :: det_de ! The partial derivative due to self-attraction and loading of the reference - ! geopotential with the sea surface height when tides are enabled [nondim]. + ! geopotential with the sea surface height when scalar SAL are enabled [nondim]. ! This is typically ~0.09 or less. real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points ! that acts on the barotropic flow [H T-1 ~> m s-1 or kg m-2 s-1]. @@ -4362,6 +4363,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! the answers from the end of 2018. Otherwise, use more efficient ! or general expressions. logical :: use_BT_cont_type + logical :: use_tides character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -4383,8 +4385,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%module_is_initialized = .true. CS%diag => diag ; CS%Time => Time - if (present(tides_CSp)) then - CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) then + CS%SAL_CSp => SAL_CSp endif ! Read all relevant parameters and write them to the model log. @@ -4523,11 +4525,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) - call get_param(param_file, mdl, "TIDES", CS%tides, & + call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=use_tides) det_de = 0.0 - if (CS%tides .and. associated(CS%tides_CSp)) & - call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + if (CS%calculate_SAL .and. associated(CS%SAL_CSp)) & + call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) call get_param(param_file, mdl, "BAROTROPIC_TIDAL_SAL_BUG", CS%tidal_sal_bug, & "If true, the tidal self-attraction and loading anomaly in the barotropic "//& "solver has the wrong sign, replicating a long-standing bug with a scalar "//& diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index eebb7d6b8a..ae9e304736 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -60,6 +60,8 @@ module MOM_dynamics_split_RK2 use MOM_PressureForce, only : PressureForce_init use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_thickness_diffuse, only : thickness_diffuse_CS +use MOM_self_attr_load, only : SAL_CS +use MOM_self_attr_load, only : SAL_init, SAL_end use MOM_tidal_forcing, only : tidal_forcing_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end use MOM_unit_scaling, only : unit_scale_type @@ -159,6 +161,7 @@ module MOM_dynamics_split_RK2 !! end of the timestep have been stored for use in the next !! predictor step. This is used to accomodate various generations !! of restart files. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: use_tides !< If true, tidal forcing is enabled. logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D !! variables that are needed to reproduce across restarts, @@ -233,6 +236,8 @@ module MOM_dynamics_split_RK2 type(set_visc_CS), pointer :: set_visc_CSp => NULL() !> A pointer to the barotropic stepping control structure type(barotropic_CS) :: barotropic_CSp + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. @@ -1276,6 +1281,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "TIDES", CS%use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) call get_param(param_file, mdl, "BE", CS%be, & "If SPLIT is true, BE determines the relative weighting "//& "of a 2nd-order Runga-Kutta baroclinic time stepping "//& @@ -1376,9 +1383,10 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & - CS%tides_CSp) + CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) @@ -1414,7 +1422,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & - CS%tides_CSp) + CS%SAL_CSp) if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then @@ -1710,6 +1718,7 @@ subroutine end_dyn_split_RK2(CS) deallocate(CS%vertvisc_CSp) call hor_visc_end(CS%hor_visc) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) call CoriolisAdv_end(CS%CoriolisAdv) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 80f7853744..c87e6e9958 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -87,7 +87,8 @@ module MOM_dynamics_unsplit use MOM_open_boundary, only : open_boundary_zero_normal_flow use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS -use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -120,6 +121,8 @@ module MOM_dynamics_unsplit !! and in the calculation of the turbulent mixed layer properties !! for viscosity. The default should be true, but it is false. logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. @@ -153,6 +156,8 @@ module MOM_dynamics_unsplit type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. @@ -625,7 +630,6 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -650,8 +654,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mdl, "TIDES", use_tides, & + call get_param(param_file, mdl, "TIDES", CS%use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) @@ -668,9 +674,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & - CS%tides_CSp) + CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) @@ -722,6 +729,9 @@ subroutine end_dyn_unsplit(CS) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + deallocate(CS) end subroutine end_dyn_unsplit diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index d1afca51d9..b515229566 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -86,7 +86,8 @@ module MOM_dynamics_unsplit_RK2 use MOM_open_boundary, only : open_boundary_zero_normal_flow use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS -use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -123,6 +124,8 @@ module MOM_dynamics_unsplit_RK2 !! turbulent mixed layer properties for viscosity. !! The default should be true, but it is false. logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. @@ -156,6 +159,8 @@ module MOM_dynamics_unsplit_RK2 type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. @@ -573,7 +578,6 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -614,8 +618,10 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mdl, "TIDES", use_tides, & + call get_param(param_file, mdl, "TIDES", CS%use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) @@ -632,9 +638,10 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & - CS%tides_CSp) + CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) @@ -685,6 +692,9 @@ subroutine end_dyn_unsplit_RK2(CS) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + deallocate(CS) end subroutine end_dyn_unsplit_RK2 diff --git a/src/parameterizations/lateral/MOM_load_love_numbers.F90 b/src/parameterizations/lateral/MOM_load_love_numbers.F90 index 84819b5915..3d573d894d 100644 --- a/src/parameterizations/lateral/MOM_load_love_numbers.F90 +++ b/src/parameterizations/lateral/MOM_load_love_numbers.F90 @@ -1452,30 +1452,32 @@ module MOM_load_love_numbers /), (/4, lmax+1/)) !< Load Love numbers !> \namespace mom_load_love_numbers -!! This module serves the sole purpose of storing load Love number. The Love numbers are used for the self-attraction -!! and loading (SAL) calculation, which is currently embedded in MOM_tidal_forcing module. This separate module ensures -!! the readability of the tidal module. +!! This module serves the sole purpose of storing load Love number. The Love numbers are used for the spherical harmonic +!! self-attraction and loading (SAL) calculation in MOM_self_attr_load module. This separate module ensures readability +!! of the SAL module. !! !! Variable Love_Data stores the Love numbers up to degree 1440. From left to right: degree, h, l, and k. Data in this !! module is imported from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los Alamos -!! National Laboratory and University of Michigan (Barton et al. (2022) and Brus et al. (2022)). The load Love numbers +!! National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2022)]. The load Love numbers !! are from Wang et al. (2012), which are in the center of mass of total Earth system reference frame (CM). When used, -!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) (Blewitt (2003)), +!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) [Blewitt (2003)], !! as in subroutine calc_love_scaling in MOM_tidal_forcing module. !! !! References: !! -!! Barton, K.N., Nairita, P., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J., -!! Wirasaet, D., and Schindelegger, M., 2022: Performance of Model for Prediction Across Scales (MPAS) Ocean as a -!! Global Barotropic Tide Model. Journal of Advances in Modeling Earth Systems, in review. +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 !! !! Blewitt, G., 2003. Self‐consistency in reference frames, geocenter definition, and surface loading of the solid !! Earth. Journal of geophysical research: solid earth, 108(B2). !! https://doi.org/10.1029/2002JB002082 !! -!! Brus, S.R., Barton, K.N., Nairita, P., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., -!! Westerink, J., and Schindelegger, M., 2022: Scalable self attraction and loading calculations for unstructured ocean -!! models. Ocean Modelling, in review. +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 !! !! Wang, H., Xiang, L., Jia, L., Jiang, L., Wang, Z., Hu, B. and Gao, P., 2012. Load Love numbers and Green's functions !! for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0. diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 new file mode 100644 index 0000000000..fb27cfa346 --- /dev/null +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -0,0 +1,271 @@ +module MOM_self_attr_load + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end, order2index, calc_lmax +use MOM_spherical_harmonics, only : spherical_harmonics_forward, spherical_harmonics_inverse +use MOM_spherical_harmonics, only : sht_CS +use MOM_load_love_numbers, only : Love_Data + +implicit none ; private + +public calc_SAL, scalar_SAL_sensitivity, SAL_init, SAL_end + +#include + +!> The control structure for the MOM_self_attr_load module +type, public :: SAL_CS ; private + logical :: use_sal_scalar !< If true, use the scalar approximation when + !! calculating self-attraction and loading. + real :: sal_scalar !< The constant of proportionality between sea surface + !! height (really it should be bottom pressure) anomalies + !! and bottom geopotential anomalies [nondim]. + logical :: use_prev_tides !< If true, use the SAL from the previous iteration of the tides + !! to facilitate convergence. + logical :: use_sal_sht !< If true, use online spherical harmonics to calculate SAL + type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) for SAL + integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] + real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nodim] + real, allocatable :: Snm_Re(:), & !< Real and imaginary SHT coefficient for SHT SAL + Snm_Im(:) !< [Z ~> m] +end type SAL_CS + +integer :: id_clock_SAL !< CPU clock for self-attraction and loading + +contains + +!> This subroutine calculates seawater self-attraction and loading based on sea surface height. This should +!! be changed into bottom pressure anomaly in the future. Note that the SAL calculation applies to all motions +!! across the spectrum. Tidal-specific methods that assume periodicity, i.e. iterative and read-in SAL, are +!! stored in MOM_tidal_forcing module. +subroutine calc_SAL(eta, eta_sal, G, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from + !! a time-mean geoid [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The sea surface height anomaly from + !! self-attraction and loading [Z ~> m]. + type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call to SAL_init. + + ! Local variables + integer :: n, m, l + integer :: Isq, Ieq, Jsq, Jeq + integer :: i, j + real :: eta_prop + + call cpu_clock_begin(id_clock_SAL) + + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + ! use the scalar approximation, iterative tidal SAL or no SAL + call scalar_SAL_sensitivity(CS, eta_prop) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = eta_prop*eta(i,j) + enddo ; enddo + + if (CS%use_sal_sht) then ! use the spherical harmonics method + call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd) + + ! Multiply scaling factors to each mode + do m = 0,CS%sal_sht_Nd + l = order2index(m, CS%sal_sht_Nd) + do n = m,CS%sal_sht_Nd + CS%Snm_Re(l+n-m) = CS%Snm_Re(l+n-m) * CS%Love_Scaling(l+n-m) + CS%Snm_Im(l+n-m) = CS%Snm_Im(l+n-m) * CS%Love_Scaling(l+n-m) + enddo + enddo + + call spherical_harmonics_inverse(G, CS%sht, CS%Snm_Re, CS%Snm_Im, eta_sal, CS%sal_sht_Nd) + + call pass_var(eta_sal, G%domain) + endif + + call cpu_clock_end(id_clock_SAL) +end subroutine calc_SAL + +!> This subroutine calculates the partial derivative of the local geopotential height with the input +!! sea surface height due to the scalar approximation of self-attraction and loading. +subroutine scalar_SAL_sensitivity(CS, deta_sal_deta) + type(SAL_CS), intent(in) :: CS !< The control structure returned by a previous call to SAL_init. + real, intent(out) :: deta_sal_deta !< The partial derivative of eta_sal with + !! the local value of eta [nondim]. + + if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then + deta_sal_deta = 2.0*CS%SAL_SCALAR + elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then + deta_sal_deta = CS%SAL_SCALAR + else + deta_sal_deta = 0.0 + endif +end subroutine scalar_SAL_sensitivity + +!> This subroutine calculates coefficients of the spherical harmonic modes for self-attraction and loading. +!! The algorithm is based on the SAL implementation in MPAS-ocean, which was modified by Kristin Barton from +!! routine written by K. Quinn (March 2010) and modified by M. Schindelegger (May 2017). +subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) + integer, intent(in) :: nlm !< Maximum spherical harmonics degree [nondim] + real, intent(in) :: rhoW !< The average density of sea water [R ~> kg m-3] + real, intent(in) :: rhoE !< The average density of Earth [R ~> kg m-3] + real, dimension(:), intent(out) :: Love_Scaling !< Scaling factors for inverse SHT [nondim] + + ! Local variables + real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames + real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers + integer :: n_tot ! Size of the stored Love numbers + integer :: n, m, l + + n_tot = size(Love_Data, dim=2) + + if (nlm+1 > n_tot) call MOM_error(FATAL, "MOM_tidal_forcing " // & + "calc_love_scaling: maximum spherical harmonics degree is larger than " // & + "the size of the stored Love numbers in MOM_load_love_number.") + + allocate(HDat(nlm+1), LDat(nlm+1), KDat(nlm+1)) + HDat(:) = Love_Data(2,1:nlm+1) ; LDat(:) = Love_Data(3,1:nlm+1) ; KDat(:) = Love_Data(4,1:nlm+1) + + ! Convert reference frames from CM to CF + if (nlm > 0) then + H1 = HDat(2) ; L1 = LDat(2) ; K1 = KDat(2) + HDat(2) = ( 2.0 / 3.0) * (H1 - L1) + LDat(2) = (-1.0 / 3.0) * (H1 - L1) + KDat(2) = (-1.0 / 3.0) * H1 - (2.0 / 3.0) * L1 - 1.0 + endif + + do m=0,nlm ; do n=m,nlm + l = order2index(m,nlm) + Love_Scaling(l+n-m) = (3.0 / real(2*n+1)) * (rhoW / rhoE) * (1.0 + KDat(n+1) - HDat(n+1)) + enddo ; enddo +end subroutine calc_love_scaling + +!> This subroutine initializeds the self-attraction and loading control structure. +subroutine SAL_init(G, US, param_file, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(SAL_CS), intent(inout) :: CS !< Self-attraction and loading control structure + +# include "version_variable.h" + character(len=40) :: mdl = "MOM_self_attr_load" ! This module's name. + integer :: lmax ! Total modes of the real spherical harmonics [nondim] + real :: rhoW ! The average density of sea water [R ~> kg m-3]. + real :: rhoE ! The average density of Earth [R ~> kg m-3]. + + logical :: calculate_sal + logical :: tides, tidal_sal_from_file + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, '', "TIDES", tides, default=.false., do_not_log=.True.) + + CS%use_prev_tides = .false. + tidal_sal_from_file = .false. + if (tides) then + call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_prev_tides,& + default=.false., do_not_log=.True.) + call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", tidal_sal_from_file,& + default=.false., do_not_log=.True.) + endif + + call get_param(param_file, mdl, "TIDE_USE_SAL_SCALAR", CS%use_sal_scalar, & + "If true and TIDES is true, use the scalar approximation "//& + "when calculating self-attraction and loading.", & + default=.not.tidal_sal_from_file) + if (CS%use_sal_scalar .or. CS%use_prev_tides) & + call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & + fail_if_missing=.true.) + + call get_param(param_file, mdl, "TIDAL_SAL_SHT", CS%use_sal_sht, & + "If true, use the online spherical harmonics method to calculate "//& + "self-attraction and loading term in tides.", default=.false.) + + call get_param(param_file, mdl, "CALCULATE_SAL", calculate_sal, & + "If true, calculate self-attraction and loading.", default=tides) + + ! ! Default USE_SAL is TRUE for now to keep backward compatibility with old MOM_INPUT files. It should be changed to + ! ! FALSE in the future (mostly to avoid the SSH calculations in MOM_PressureForce). In that case, the following check + ! ! informs prior tidal experiments that use scalar or iterative SAL to include USE_SAL flag, as the USE_SAL flag + ! ! overrules the option flags. + ! if ((.not. calculate_sal) .and. (CS%use_prev_tides .or. CS%use_sal_scalar .or. CS%use_sal_sht)) & + ! call MOM_error(FATAL, trim(mdl)//": USE_SAL is False but one of the options is True. Nothing will happen.") + + if (CS%use_sal_sht) then + call get_param(param_file, mdl, "TIDAL_SAL_SHT_DEGREE", CS%sal_sht_Nd, & + "The maximum degree of the spherical harmonics transformation used for "// & + "calculating the self-attraction and loading term.", & + default=0, do_not_log=.not. CS%use_sal_sht) + call get_param(param_file, mdl, "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) + call get_param(param_file, mdl, "RHO_E", rhoE, & + "The mean solid earth density. This is used for calculating the "// & + "self-attraction and loading term.", units="kg m-3", & + default=5517.0, scale=US%kg_m3_to_R, do_not_log=.not. CS%use_sal_sht) + lmax = calc_lmax(CS%sal_sht_Nd) + allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 + allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 + + allocate(CS%Love_Scaling(lmax)); CS%Love_Scaling(:) = 0.0 + call calc_love_scaling(CS%sal_sht_Nd, rhoW, rhoE, CS%Love_Scaling) + call spherical_harmonics_init(G, param_file, CS%sht) + endif + + id_clock_SAL = cpu_clock_id('(Ocean SAL)', grain=CLOCK_MODULE) + +end subroutine SAL_init + +!> This subroutine deallocates memory associated with the SAL module. +subroutine SAL_end(CS) + type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call + !! to SAL_init; it is deallocated here. + if (CS%use_sal_sht) then + if (allocated(CS%Love_Scaling)) deallocate(CS%Love_Scaling) + if (allocated(CS%Snm_Re)) deallocate(CS%Snm_Re) + if (allocated(CS%Snm_Im)) deallocate(CS%Snm_Im) + call spherical_harmonics_end(CS%sht) + endif +end subroutine SAL_end + +!> \namespace self_attr_load +!! +!! This module contains methods to calculate self-attraction and loading (SAL) as a function of sea surface height (SSH) +!! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or +!! storm surges, but the effect applys to all motions. +!! +!! If TIDE_USE_SAL_SCALAR is true, a scalar approximiation is applied (Accad and Pekeris 1978) and the SAL is simply +!! a fraction (set by TIDE_SAL_SCALAR_VALUE, usualy around 10% for global tides) of local SSH . For the tides, the +!! scalar approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, +!! Arbic et al. (2004)]. +!! +!! If TIDAL_SAL_SHT is true, a more accurate online spherical harmonic transforms are used to calculate SAL. +!! Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set by +!! TIDAL_SAL_SHT_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean +!! developed by Los Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. +!! +!! References: +!! +!! Accad, Y. and Pekeris, C.L., 1978. Solution of the tidal equations for the M2 and S2 tides in the world oceans from a +!! knowledge of the tidal potential alone. Philosophical Transactions of the Royal Society of London. Series A, +!! Mathematical and Physical Sciences, 290(1368), pp.235-266. +!! https://doi.org/10.1098/rsta.1978.0083 +!! +!! Arbic, B.K., Garner, S.T., Hallberg, R.W. and Simmons, H.L., 2004. The accuracy of surface elevations in forward +!! global barotropic and baroclinic tide models. Deep Sea Research Part II: Topical Studies in Oceanography, 51(25-26), +!! pp.3069-3101. +!! https://doi.org/10.1016/j.dsr2.2004.09.014 +!! +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 +!! +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 +end module MOM_self_attr_load diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 95a9df808c..b20df036e0 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -330,7 +330,7 @@ end function order2index !! Currently, the transforms are for t-cell fields only. !! !! This module is stemmed from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los -!! Alamos National Laboratory and University of Michigan (Barton et al. (2022) and Brus et al. (2022)). The algorithm +!! Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. The algorithm !! for forward and inverse transforms loosely follows Schaeffer (2013). !! !! In forward transform, a two-dimensional physical field can be projected into a series of spherical harmonics. The @@ -368,13 +368,15 @@ end function order2index !! !! References: !! -!! Barton, K.N., Nairita, P., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J., -!! Wirasaet, D., and Schindelegger, M., 2022: Performance of Model for Prediction Across Scales (MPAS) Ocean as a -!! Global Barotropic Tide Model. Journal of Advances in Modeling Earth Systems, in review. +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 !! -!! Brus, S.R., Barton, K.N., Nairita, P., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., -!! Westerink, J., and Schindelegger, M., 2022: Scalable self attraction and loading calculations for unstructured ocean -!! models. Ocean Modelling, in review. +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 !! !! Schaeffer, N., 2013. Efficient spherical harmonic transforms aimed at pseudospectral numerical simulations. !! Geochemistry, Geophysics, Geosystems, 14(3), pp.751-758. diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index b2fd8f0ea5..358ec3dc57 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -12,15 +12,10 @@ module MOM_tidal_forcing use MOM_io, only : field_exists, file_exists, MOM_read_data use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) use MOM_unit_scaling, only : unit_scale_type -use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end, order2index, calc_lmax -use MOM_spherical_harmonics, only : spherical_harmonics_forward, spherical_harmonics_inverse -use MOM_spherical_harmonics, only : sht_CS -use MOM_load_love_numbers, only : Love_Data implicit none ; private public calc_tidal_forcing, tidal_forcing_init, tidal_forcing_end -public tidal_forcing_sensitivity ! MOM_open_boundary uses the following to set tides on the boundary. public astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency @@ -38,8 +33,6 @@ module MOM_tidal_forcing !> The control structure for the MOM_tidal_forcing module type, public :: tidal_forcing_CS ; private - logical :: use_sal_scalar !< If true, use the scalar approximation when - !! calculating self-attraction and loading. logical :: tidal_sal_from_file !< If true, Read the tidal self-attraction !! and loading from input files, specified !! by TIDAL_INPUT_FILE. @@ -49,7 +42,6 @@ module MOM_tidal_forcing !! equilibrium tide. Set to false if providing tidal phases !! that have already been shifted by the !! astronomical/equilibrium argument. - logical :: tidal_sal_sht !< If true, use online spherical harmonics to calculate SAL real :: sal_scalar !< The constant of proportionality between sea surface !! height (really it should be bottom pressure) anomalies !! and bottom geopotential anomalies [nondim]. @@ -76,15 +68,9 @@ module MOM_tidal_forcing cosphase_prev(:,:,:), & !< The cosine of the phase of the amphidromes in the previous tidal solutions [nondim]. sinphase_prev(:,:,:), & !< The sine of the phase of the amphidromes in the previous tidal solutions [nondim]. amp_prev(:,:,:) !< The amplitude of the previous tidal solution [Z ~> m]. - type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) for SAL - integer :: sal_sht_Nd !< Maximum degree for SHT [nondim] - real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nondim] - real, allocatable :: Snm_Re(:), & !< Real SHT coefficient for SHT SAL [Z ~> m] - Snm_Im(:) !< Imaginary SHT coefficient for SHT SAL [Z ~> m] end type tidal_forcing_CS integer :: id_clock_tides !< CPU clock for tides -integer :: id_clock_SAL !< CPU clock for self-attraction and loading contains @@ -366,12 +352,8 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) "If true, use the SAL from the previous iteration of the "//& "tides to facilitate convergent iteration. "//& "This is only used if TIDES is true.", default=.false.) - call get_param(param_file, mdl, "TIDE_USE_SAL_SCALAR", CS%use_sal_scalar, & - "If true and TIDES is true, use the scalar approximation "//& - "when calculating self-attraction and loading.", & - default=.not.CS%tidal_sal_from_file) ! If it is being used, sal_scalar MUST be specified in param_file. - if (CS%use_sal_scalar .or. CS%use_prev_tides) & + if (CS%use_prev_tides) & call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & "The constant of proportionality between sea surface "//& "height (really it should be bottom pressure) anomalies "//& @@ -379,10 +361,6 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & fail_if_missing=.true.) - call get_param(param_file, mdl, "TIDAL_SAL_SHT", CS%tidal_sal_sht, & - "If true, use the online spherical harmonics method to calculate "//& - "self-attraction and loading term in tides.", default=.false.) - if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & &"to accommodate all the registered tidal constituents.")') nc @@ -542,74 +520,10 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) enddo endif - if (CS%tidal_sal_sht) then - call get_param(param_file, mdl, "TIDAL_SAL_SHT_DEGREE", CS%sal_sht_Nd, & - "The maximum degree of the spherical harmonics transformation used for "// & - "calculating the self-attraction and loading term for tides.", & - default=0, do_not_log=.not.CS%tidal_sal_sht) - call get_param(param_file, mdl, "RHO_0", rhoW, & - "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, do_not_log=.True.) - call get_param(param_file, mdl, "RHO_E", rhoE, & - "The mean solid earth density. This is used for calculating the "// & - "self-attraction and loading term.", & - units="kg m-3", default=5517.0, scale=US%kg_m3_to_R, & - do_not_log=.not.CS%tidal_sal_sht) - lmax = calc_lmax(CS%sal_sht_Nd) - allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 - allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 - - allocate(CS%Love_Scaling(lmax)); CS%Love_Scaling(:) = 0.0 - call calc_love_scaling(CS%sal_sht_Nd, rhoW, rhoE, CS%Love_Scaling) - call spherical_harmonics_init(G, param_file, CS%sht) - id_clock_SAL = cpu_clock_id('(Ocean SAL)', grain=CLOCK_ROUTINE) - endif - id_clock_tides = cpu_clock_id('(Ocean tides)', grain=CLOCK_MODULE) end subroutine tidal_forcing_init -!> This subroutine calculates coefficients of the spherical harmonic modes for self-attraction and loading. -!! The algorithm is based on the SAL implementation in MPAS-ocean, which was modified by Kristin Barton from -!! routine written by K. Quinn (March 2010) and modified by M. Schindelegger (May 2017). -subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) - integer, intent(in) :: nlm !< Maximum spherical harmonics degree [nondim] - real, intent(in) :: rhoW !< The average density of sea water [R ~> kg m-3] - real, intent(in) :: rhoE !< The average density of Earth [R ~> kg m-3] - real, dimension(:), intent(out) :: Love_Scaling !< Scaling factors for inverse SHT [nondim] - - ! Local variables - real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames [nondim] - real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers [nondim] - integer :: n_tot ! Size of the stored Love numbers - integer :: n, m, l - - n_tot = size(Love_Data, dim=2) - - if (nlm+1 > n_tot) call MOM_error(FATAL, "MOM_tidal_forcing " // & - "calc_love_scaling: maximum spherical harmonics degree is larger than " // & - "the size of the stored Love numbers in MOM_load_love_number.") - - allocate(HDat(nlm+1), LDat(nlm+1), KDat(nlm+1)) - HDat(:) = Love_Data(2,1:nlm+1) ; LDat(:) = Love_Data(3,1:nlm+1) ; KDat(:) = Love_Data(4,1:nlm+1) - - ! Convert reference frames from CM to CF - if (nlm > 0) then - H1 = HDat(2) ; L1 = LDat(2) ; K1 = KDat(2) - HDat(2) = ( 2.0 / 3.0) * (H1 - L1) - LDat(2) = (-1.0 / 3.0) * (H1 - L1) - KDat(2) = (-1.0 / 3.0) * H1 - (2.0 / 3.0) * L1 - 1.0 - endif - - do m=0,nlm ; do n=m,nlm - l = order2index(m,nlm) - Love_Scaling(l+n-m) = (3.0 / real(2*n+1)) * (rhoW / rhoE) * (1.0 + KDat(n+1) - HDat(n+1)) - enddo ; enddo -end subroutine calc_love_scaling - !> This subroutine finds a named variable in a list of files and reads its !! values into a domain-decomposed 2-d array subroutine find_in_files(filenames, varname, array, G, scale) @@ -643,47 +557,21 @@ subroutine find_in_files(filenames, varname, array, G, scale) end subroutine find_in_files -!> This subroutine calculates returns the partial derivative of the local -!! geopotential height with the input sea surface height due to self-attraction -!! and loading. -subroutine tidal_forcing_sensitivity(G, CS, deta_tidal_deta) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a previous call to tidal_forcing_init. - real, intent(out) :: deta_tidal_deta !< The partial derivative of eta_tidal with - !! the local value of eta [nondim]. - - if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then - deta_tidal_deta = 2.0*CS%SAL_SCALAR - elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then - deta_tidal_deta = CS%SAL_SCALAR - else - deta_tidal_deta = 0.0 - endif -end subroutine tidal_forcing_sensitivity - !> This subroutine calculates the geopotential anomalies that drive the tides, -!! including self-attraction and loading. Optionally, it also returns the -!! partial derivative of the local geopotential height with the input sea surface -!! height. For now, eta and eta_tidal are both geopotential heights in depth -!! units, but probably the input for eta should really be replaced with the -!! column mass anomalies. -subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, US, CS) +!! including tidal self-attraction and loading from previous solutions. +subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< The time for the calculation. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from - !! a time-mean geoid [Z ~> m]. + type(time_type), intent(in) :: Time !< The time for the caluculation. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_tidal !< The tidal forcing geopotential height !! anomalies [Z ~> m]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(tidal_forcing_CS), intent(inout) :: CS !< The control structure returned by a + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a !! previous call to tidal_forcing_init. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: eta_sal !< SAL calculated by spherical harmonics real :: now ! The relative time compared with the tidal reference [T ~> s] real :: amp_cosomegat, amp_sinomegat ! The tidal amplitudes times the components of phase [Z ~> m] real :: cosomegat, sinomegat ! The components of the phase [nondim] - real :: eta_prop ! The nondimenional constant of proportionality between eta and eta_tidal [nondim] integer :: i, j, c, m, is, ie, js, je, Isq, Ieq, Jsq, Jeq is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -697,16 +585,8 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, US, CS) now = US%s_to_T * time_type_to_real(Time - cs%time_ref) - if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then - eta_prop = 2.0*CS%SAL_SCALAR - elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then - eta_prop = CS%SAL_SCALAR - else - eta_prop = 0.0 - endif - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_prop*eta(i,j) + eta_tidal(i,j) = 0.0 enddo ; enddo do c=1,CS%nc @@ -737,50 +617,10 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, US, CS) enddo ; enddo enddo ; endif - if (CS%tidal_sal_sht) then - eta_sal(:,:) = 0.0 - call calc_SAL_sht(eta, eta_sal, G, CS) - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) + eta_sal(i,j) - enddo ; enddo - endif call cpu_clock_end(id_clock_tides) end subroutine calc_tidal_forcing -!> This subroutine calculates self-attraction and loading using the spherical harmonics method. -subroutine calc_SAL_sht(eta, eta_sal, G, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from - !! a time-mean geoid [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The sea surface height anomaly from - !! self-attraction and loading [Z ~> m]. - type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure - - ! Local variables - integer :: n, m, l - - call cpu_clock_begin(id_clock_SAL) - - call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd) - - ! Multiply scaling factors to each mode - do m = 0,CS%sal_sht_Nd - l = order2index(m, CS%sal_sht_Nd) - do n = m,CS%sal_sht_Nd - CS%Snm_Re(l+n-m) = CS%Snm_Re(l+n-m) * CS%Love_Scaling(l+n-m) - CS%Snm_Im(l+n-m) = CS%Snm_Im(l+n-m) * CS%Love_Scaling(l+n-m) - enddo - enddo - - call spherical_harmonics_inverse(G, CS%sht, CS%Snm_Re, CS%Snm_Im, eta_sal, CS%sal_sht_Nd) - - call pass_var(eta_sal, G%domain) - - call cpu_clock_end(id_clock_SAL) -end subroutine calc_SAL_sht - !> This subroutine deallocates memory associated with the tidal forcing module. subroutine tidal_forcing_end(CS) type(tidal_forcing_CS), intent(inout) :: CS !< The control structure returned by a previous call @@ -796,13 +636,6 @@ subroutine tidal_forcing_end(CS) if (allocated(CS%cosphase_prev)) deallocate(CS%cosphase_prev) if (allocated(CS%sinphase_prev)) deallocate(CS%sinphase_prev) if (allocated(CS%amp_prev)) deallocate(CS%amp_prev) - - if (CS%tidal_sal_sht) then - if (allocated(CS%Love_Scaling)) deallocate(CS%Love_Scaling) - if (allocated(CS%Snm_Re)) deallocate(CS%Snm_Re) - if (allocated(CS%Snm_Im)) deallocate(CS%Snm_Im) - call spherical_harmonics_end(CS%sht) - endif end subroutine tidal_forcing_end !> \namespace tidal_forcing @@ -823,28 +656,16 @@ end subroutine tidal_forcing_end !! can be changed at run time by setting variables like TIDE_M2_FREQ, !! TIDE_M2_AMP and TIDE_M2_PHASE_T0 (for M2). !! -!! In addition, the approach to calculating self-attraction and -!! loading is set at run time. The default is to use the scalar -!! approximation, with a coefficient TIDE_SAL_SCALAR_VALUE that must -!! be set in the run-time file (for global runs, 0.094 is typical). -!! Alternately, TIDAL_SAL_FROM_FILE can be set to read the SAL from -!! a file containing the results of a previous simulation. To iterate -!! the SAL to convergence, USE_PREVIOUS_TIDES may be useful (for -!! details, see Arbic et al., 2004, DSR II). With TIDAL_SAL_FROM_FILE -!! or USE_PREVIOUS_TIDES,a list of input files must be provided to -!! describe each constituent's properties from a previous solution. -!! -!! This module also contains a method to calculate self-attraction -!! and loading using spherical harmonic transforms. The algorithm is -!! based on SAL calculation in Model for Prediction Across Scales -!! (MPAS)-Ocean developed by Los Alamos National Laboratory and -!! University of Michigan (Barton et al. (2022) and Brus et al. (2022)). -!! -!! Barton, K.N., Nairita, P., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J., -!! Wirasaet, D., and Schindelegger, M., 2022: Performance of Model for Prediction Across Scales (MPAS) Ocean as a -!! Global Barotropic Tide Model. Journal of Advances in Modeling Earth Systems, in review. -!! -!! Brus, S.R., Barton, K.N., Nairita, P., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., -!! Westerink, J., and Schindelegger, M., 2022: Scalable self attraction and loading calculations for unstructured ocean -!! models. Ocean Modelling, in review. +!! In addition, approaches to calculate self-attraction and loading +!! due to tides (harmonics of astronomical forcing frequencies) +!! are provided. TIDAL_SAL_FROM_FILE can be set to read the phase and +!! amplitude of the tidal SAL. USE_PREVIOUS_TIDES may be useful in +!! combination with the scalar approximation to iterate the SAL to +!! convergence (for details, see Arbic et al., 2004, DSR II). With +!! TIDAL_SAL_FROM_FILE or USE_PREVIOUS_TIDES, a list of input files +!! must be provided to describe each constituent's properties from +!! a previous solution. The online SAL calculations that are functions +!! of SSH (rather should be bottom pressure anmoaly), either a scalar +!! approximation or with spherical harmonic transforms, are located in +!! MOM_self_attr_load. end module MOM_tidal_forcing From 4fec906695f8dc7ae16ead8d9d2b9b7f2a5d3b88 Mon Sep 17 00:00:00 2001 From: He Wang Date: Wed, 26 Apr 2023 09:54:15 -0400 Subject: [PATCH 069/146] Decompose output from calc_tidal_forcing The output field eta_tidal from subroutine calc_tidal_forcing originally contains both equilibrium tides and tidal SAL that is based on previous solutions (TIDAL_SAL_FROM_FILE and USE_PREV_TIDES). This commit decompose the two fields for better diagnostics. This also makes answers using USE_PREV_TIDES is not changed if only one tidal constituent is used. New diagnostics ('e_tidal_eq' and 'e_tidal_sal') are added in pressure force modules for the decomposed fields. Note that 'e_tidal' still includes all tidal fields + SAL fields to be backward compatible. --- src/core/MOM_PressureForce_FV.F90 | 54 ++++++++++++------- src/core/MOM_PressureForce_Montgomery.F90 | 50 ++++++++++------- .../lateral/MOM_tidal_forcing.F90 | 36 +++++++------ 3 files changed, 86 insertions(+), 54 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 27a4e3ae5a..4dc354b01c 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -62,7 +62,9 @@ module MOM_PressureForce_FV !! By the default (1) is for a piecewise linear method logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF - integer :: id_e_tidal = -1 !< Diagnostic identifier + integer :: id_e_tide = -1 !< Diagnostic identifier + integer :: id_e_tide_eq = -1 !< Diagnostic identifier + integer :: id_e_tide_sal = -1 !< Diagnostic identifier integer :: id_e_sal = -1 !< Diagnostic identifier integer :: id_rho_pgf = -1 !< Diagnostic identifier integer :: id_rho_stanley_pgf = -1 !< Diagnostic identifier @@ -120,8 +122,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ dp, & ! The (positive) change in pressure across a layer [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources - ! and harmonic self-attraction and loading specific to tides [Z ~> m]. + e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. + e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. dM, & ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the @@ -324,10 +327,10 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (CS%tides) then ! Find and add the tidal geopotential anomaly. - call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * (e_sal(i,j) + e_tidal(i,j)) + za(i,j) = za(i,j) - GV%g_Earth * (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo else !$OMP parallel do default(shared) @@ -430,9 +433,12 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif endif - ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) end subroutine PressureForce_FV_nonBouss @@ -466,13 +472,15 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in depth units [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: & e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources - ! and harmonic self-attraction and loading specific to tides [Z ~> m]. + e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources + ! [Z ~> m]. + e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: & - Rho_cv_BL ! The coordinate potential density in the deepest variable + Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & dz_geo, & ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. @@ -574,10 +582,10 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tidal(i,j))) + e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))) enddo ; enddo else !$OMP parallel do default(shared) @@ -783,7 +791,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! what is used for eta in btstep. See how e was calculated about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j) + e_tidal(i,j))*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) @@ -830,9 +838,13 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif endif - ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + if (CS%id_rho_pgf>0) call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) if (CS%id_rho_stanley_pgf>0) call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) @@ -922,12 +934,16 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, Time, 'p in PGF with Stanley correction', 'Pa', conversion=US%RL2_T2_to_Pa) endif if (CS%calculate_SAL) then - CS%id_e_sal = register_diag_field('ocean_model', 'e_SAL', diag%axesT1, & - Time, 'Self-attraction and loading height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_sal = register_diag_field('ocean_model', 'e_sal', diag%axesT1, & + Time, 'Self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif 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) + CS%id_e_tide = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, Time, & + 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_eq = register_diag_field('ocean_model', 'e_tide_eq', diag%axesT1, Time, & + 'Equilibrium tides height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_sal = register_diag_field('ocean_model', 'e_tide_sal', diag%axesT1, Time, & + 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif CS%GFS_scale = 1.0 diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 5223afbccb..c687c0a40a 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -47,7 +47,8 @@ module MOM_PressureForce_Mont real, allocatable :: PFv_bc(:,:,:) !< Meridional accelerations due to pressure gradients !! deriving from density gradients within layers [L T-2 ~> m s-2]. !>@{ Diagnostic IDs - integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1, id_e_sal = -1 + integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_sal = -1 + integer :: id_e_tide = -1, id_e_tide_eq = -1, id_e_tide_sal = -1 !>@} type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< The tidal forcing control structure @@ -107,8 +108,9 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb dp_star, & ! Layer thickness after compensation for compressibility [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_sal, & ! Bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. - e_tidal, & ! Bottom geopotential anomaly due to tidal forces from astronomical sources - ! and harmonic self-attraction and loading specific to tides [Z ~> m]. + e_tide_eq, & ! Bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. + e_tide_sal, & ! Bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. geopot_bot ! Bottom geopotential relative to a temporally fixed reference value, ! including any tidal contributions [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate @@ -215,10 +217,10 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + e_tidal(i,j) + G%bathyT(i,j)) + geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j) + G%bathyT(i,j)) enddo ; enddo else !$OMP parallel do default(shared) @@ -359,9 +361,12 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) end subroutine PressureForce_Mont_nonBouss @@ -410,8 +415,10 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! for compressibility [Z ~> m]. real :: SSH(SZI_(G),SZJ_(G)) ! The sea surface height anomaly, in depth units [Z ~> m]. real :: e_sal(SZI_(G),SZJ_(G)) ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. - real :: e_tidal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal forces from astronomical sources - ! and harmonic self-attraction and loading specific to tides, in depth units [Z ~> m]. + real :: e_tide_eq(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal forces from astronomical sources + ! [Z ~> m]. + real :: e_tide_sal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides, in depth units [Z ~> m]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). real :: I_Rho0 ! 1/Rho0 [R-1 ~> m3 kg-1]. @@ -474,10 +481,10 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, endif if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tidal(i,j))) + e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))) enddo ; enddo else !$OMP parallel do default(shared) @@ -607,7 +614,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j)+e_tidal(i,j))*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j)+e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) @@ -619,9 +626,12 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) end subroutine PressureForce_Mont_Bouss @@ -893,12 +903,16 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, SAL_CS endif if (CS%calculate_SAL) then - CS%id_e_sal = register_diag_field('ocean_model', 'e_SAL', diag%axesT1, & - Time, 'SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_sal = register_diag_field('ocean_model', 'e_sal', diag%axesT1, Time, & + 'Self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif 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) + CS%id_e_tide = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, Time, & + 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_eq = register_diag_field('ocean_model', 'e_tide_eq', diag%axesT1, Time, & + 'Equilibrium tides height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_sal = register_diag_field('ocean_model', 'e_tide_sal', diag%axesT1, Time, & + 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif CS%GFS_scale = 1.0 diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 358ec3dc57..fcd90a4171 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -559,14 +559,16 @@ end subroutine find_in_files !> This subroutine calculates the geopotential anomalies that drive the tides, !! including tidal self-attraction and loading from previous solutions. -subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< The time for the caluculation. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_tidal !< The tidal forcing geopotential height - !! anomalies [Z ~> m]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a - !! previous call to tidal_forcing_init. +subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< The time for the caluculation. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_eq !< The geopotential height anomalies + !! due to the equilibrium tides [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_sal !< The geopotential height anomalies + !! due to the tidal SAL [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a + !! previous call to tidal_forcing_init. ! Local variables real :: now ! The relative time compared with the tidal reference [T ~> s] @@ -578,23 +580,23 @@ subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) call cpu_clock_begin(id_clock_tides) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_eq(i,j) = 0.0 + e_tide_sal(i,j) = 0.0 + enddo ; enddo + if (CS%nc == 0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; eta_tidal(i,j) = 0.0 ; enddo ; enddo return endif now = US%s_to_T * time_type_to_real(Time - cs%time_ref) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = 0.0 - enddo ; enddo - do c=1,CS%nc m = CS%struct(c) amp_cosomegat = CS%amp(c)*CS%love_no(c) * cos(CS%freq(c)*now + CS%phase0(c)) amp_sinomegat = CS%amp(c)*CS%love_no(c) * sin(CS%freq(c)*now + CS%phase0(c)) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) + (amp_cosomegat*CS%cos_struct(i,j,m) + & + e_tide_eq(i,j) = e_tide_eq(i,j) + (amp_cosomegat*CS%cos_struct(i,j,m) + & amp_sinomegat*CS%sin_struct(i,j,m)) enddo ; enddo enddo @@ -603,8 +605,8 @@ subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) + CS%ampsal(i,j,c) * & - (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) + e_tide_sal(i,j) = e_tide_sal(i,j) + CS%ampsal(i,j,c) * & + (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) enddo ; enddo enddo ; endif @@ -612,7 +614,7 @@ subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) - CS%SAL_SCALAR*CS%amp_prev(i,j,c) * & + e_tide_sal(i,j) = e_tide_sal(i,j) - CS%sal_scalar * CS%amp_prev(i,j,c) * & (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) enddo ; enddo enddo ; endif From b69d6fbd5256cd773c18b13a63920a17b9d6531d Mon Sep 17 00:00:00 2001 From: He Wang Date: Tue, 6 Jun 2023 12:21:23 -0400 Subject: [PATCH 070/146] Fix SSH for calculating SAL with flooding points SSH for SAL is modified for grid points with topography above the reference height z_ref (assumed to be land that can be flooded). Instead of eta anomaly referenced to z_ref, eta anomaly referenced to the bottom depth is used for these grid points. --- src/core/MOM_PressureForce_FV.F90 | 5 +++-- src/core/MOM_PressureForce_Montgomery.F90 | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 4dc354b01c..25301ae31d 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -315,7 +315,8 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! Find and add the self-attraction and loading geopotential anomaly. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref + SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & + - max(-G%bathyT(i,j)-G%Z_ref, 0.0) enddo ; enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) else @@ -567,7 +568,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - SSH(i,j) = -G%bathyT(i,j) - G%Z_ref + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) enddo do k=1,nz ; do i=Isq,Ieq+1 SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index c687c0a40a..53f6a5a925 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -191,7 +191,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! of self-attraction and loading. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = -G%bathyT(i,j) - G%Z_ref + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) enddo ; enddo if (use_EOS) then !$OMP parallel do default(shared) @@ -468,7 +468,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! barotropic tides. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 - do i=Isq,Ieq+1 ; SSH(i,j) = -G%bathyT(i,j) - G%Z_ref ; enddo + do i=Isq,Ieq+1 ; SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) ; enddo do k=1,nz ; do i=Isq,Ieq+1 SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo From b94a32c35d9674f1fb476b8803e584744bac9d94 Mon Sep 17 00:00:00 2001 From: He Wang Date: Tue, 6 Jun 2023 13:02:47 -0400 Subject: [PATCH 071/146] Renaming input parameter names for the SAL module Remove "TIDAL" and "TIDE" from the relevant input names of the SAL module, as SAL is not specific to the tides. This affects both scalar approximation and the fully online spherical harmonic options. * For scalar SAL, old parameter names are still acceptable, but a WARNING is given if these old names appear in MOM_input. * For read-in SAL, no change is made. * For iterative method (use_prev_tides), the use of TIDE_SAL_SCALAR_VALUE is completely deprecated, as this is a feature that is rarely used. * For harmonic SAL, a relatively recent feature, a hard obsolete is applied, i.e. if the old parameters are specified, a FATAL error is given, unless the new parameters also exist and match the values of the old parameters. List of input names changed: * TIDE_USE_SAL_SCALAR -> USE_SAL_SCALAR * TIDE_SAL_SCALAR_VALUE -> SAL_SCALAR_VALUE * TIDAL_SAL_SHT -> USE_SAL_HARMONICS * TIDAL_SAL_SHT_DEGREE -> SAL_HARMONICS_DEGREE --- .../lateral/MOM_self_attr_load.F90 | 173 +++++++++++------- .../lateral/MOM_tidal_forcing.F90 | 28 ++- 2 files changed, 117 insertions(+), 84 deletions(-) diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index fb27cfa346..be45f64cfe 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -1,15 +1,16 @@ module MOM_self_attr_load -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE -use MOM_domains, only : pass_var -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end, order2index, calc_lmax +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_obsolete_params, only : obsolete_logical, obsolete_int +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end use MOM_spherical_harmonics, only : spherical_harmonics_forward, spherical_harmonics_inverse -use MOM_spherical_harmonics, only : sht_CS -use MOM_load_love_numbers, only : Love_Data +use MOM_spherical_harmonics, only : sht_CS, order2index, calc_lmax +use MOM_load_love_numbers, only : Love_Data implicit none ; private @@ -19,19 +20,18 @@ module MOM_self_attr_load !> The control structure for the MOM_self_attr_load module type, public :: SAL_CS ; private - logical :: use_sal_scalar !< If true, use the scalar approximation when - !! calculating self-attraction and loading. - real :: sal_scalar !< The constant of proportionality between sea surface - !! height (really it should be bottom pressure) anomalies - !! and bottom geopotential anomalies [nondim]. - logical :: use_prev_tides !< If true, use the SAL from the previous iteration of the tides - !! to facilitate convergence. - logical :: use_sal_sht !< If true, use online spherical harmonics to calculate SAL - type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) for SAL - integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] + logical :: use_sal_scalar !< If true, use the scalar approximation to calculate SAL. + logical :: use_sal_sht !< If true, use online spherical harmonics to calculate SAL + logical :: use_tidal_sal_prev !< If true, read the tidal SAL from the previous iteration of + !! the tides to facilitate convergence. + real :: sal_scalar_value !< The constant of proportionality between sea surface height + !! (really it should be bottom pressure) anomalies and bottom + !! geopotential anomalies [nondim]. + type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) control structure + integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nodim] - real, allocatable :: Snm_Re(:), & !< Real and imaginary SHT coefficient for SHT SAL - Snm_Im(:) !< [Z ~> m] + real, allocatable :: Snm_Re(:), & !< Real SHT coefficient for SHT SAL [Z ~> m] + Snm_Im(:) !< Imaginary SHT coefficient for SHT SAL [Z ~> m] end type SAL_CS integer :: id_clock_SAL !< CPU clock for self-attraction and loading @@ -60,13 +60,15 @@ subroutine calc_SAL(eta, eta_sal, G, CS) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - ! use the scalar approximation, iterative tidal SAL or no SAL - call scalar_SAL_sensitivity(CS, eta_prop) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_sal(i,j) = eta_prop*eta(i,j) - enddo ; enddo + ! use the scalar approximation and/or iterative tidal SAL + if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + call scalar_SAL_sensitivity(CS, eta_prop) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = eta_prop*eta(i,j) + enddo ; enddo - if (CS%use_sal_sht) then ! use the spherical harmonics method + ! use the spherical harmonics method + elseif (CS%use_sal_sht) then call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd) ! Multiply scaling factors to each mode @@ -79,8 +81,13 @@ subroutine calc_SAL(eta, eta_sal, G, CS) enddo call spherical_harmonics_inverse(G, CS%sht, CS%Snm_Re, CS%Snm_Im, eta_sal, CS%sal_sht_Nd) - + ! Halo was not calculated in spherical harmonic transforms. call pass_var(eta_sal, G%domain) + + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = 0.0 + enddo ; enddo endif call cpu_clock_end(id_clock_SAL) @@ -93,10 +100,10 @@ subroutine scalar_SAL_sensitivity(CS, deta_sal_deta) real, intent(out) :: deta_sal_deta !< The partial derivative of eta_sal with !! the local value of eta [nondim]. - if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then - deta_sal_deta = 2.0*CS%SAL_SCALAR - elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then - deta_sal_deta = CS%SAL_SCALAR + if (CS%use_sal_scalar .and. CS%use_tidal_sal_prev) then + deta_sal_deta = 2.0*CS%sal_scalar_value + elseif (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + deta_sal_deta = CS%sal_scalar_value else deta_sal_deta = 0.0 endif @@ -140,13 +147,14 @@ subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) enddo ; enddo end subroutine calc_love_scaling -!> This subroutine initializeds the self-attraction and loading control structure. +!> This subroutine initializes the self-attraction and loading control structure. subroutine SAL_init(G, US, param_file, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(SAL_CS), intent(inout) :: CS !< Self-attraction and loading control structure + ! Local variables # include "version_variable.h" character(len=40) :: mdl = "MOM_self_attr_load" ! This module's name. integer :: lmax ! Total modes of the real spherical harmonics [nondim] @@ -154,58 +162,87 @@ subroutine SAL_init(G, US, param_file, CS) real :: rhoE ! The average density of Earth [R ~> kg m-3]. logical :: calculate_sal - logical :: tides, tidal_sal_from_file + logical :: tides, use_tidal_sal_file + real :: tide_sal_scalar_value ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, '', "TIDES", tides, default=.false., do_not_log=.True.) - - CS%use_prev_tides = .false. - tidal_sal_from_file = .false. if (tides) then - call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_prev_tides,& + call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & default=.false., do_not_log=.True.) - call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", tidal_sal_from_file,& + call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", use_tidal_sal_file, & default=.false., do_not_log=.True.) endif - call get_param(param_file, mdl, "TIDE_USE_SAL_SCALAR", CS%use_sal_scalar, & - "If true and TIDES is true, use the scalar approximation "//& - "when calculating self-attraction and loading.", & - default=.not.tidal_sal_from_file) - if (CS%use_sal_scalar .or. CS%use_prev_tides) & - call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & - "The constant of proportionality between sea surface "//& - "height (really it should be bottom pressure) anomalies "//& - "and bottom geopotential anomalies. This is only used if "//& - "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & - fail_if_missing=.true.) - - call get_param(param_file, mdl, "TIDAL_SAL_SHT", CS%use_sal_sht, & - "If true, use the online spherical harmonics method to calculate "//& - "self-attraction and loading term in tides.", default=.false.) + ! TIDE_USE_SAL_SCALAR is going to be replaced by USE_SAL_SCALAR. During the transition, the default of + ! USE_SAL_SCALAR is set to be consistent with TIDE_USE_SAL_SCALAR before the implementation of spherical + ! harmonics SAL. + ! A FATAL error is only issued when the user specified TIDE_USE_SAL_SCALAR contradicts USE_SAL_SCALAR. + call get_param(param_file, mdl, "USE_SAL_SCALAR", CS%use_sal_scalar, & + "If true, use the scalar approximation to calculate self-attraction and"//& + " loading. This parameter is to replace TIDE_USE_SAL_SCALAR, as SAL applies"//& + " to all motions. When both USE_SAL_SCALAR and TIDE_USE_SAL_SCALAR are"//& + " specified, USE_SAL_SCALAR overrides TIDE_USE_SAL_SCALAR.", & + default=tides .and. (.not.use_tidal_sal_file)) + if (tides) then + call obsolete_logical(param_file, "TIDE_USE_SAL_SCALAR", warning_val=CS%use_sal_scalar, & + hint="Use USE_SAL_SCALAR instead.") + endif + + call get_param(param_file, mdl, "USE_SAL_HARMONICS", CS%use_sal_sht, & + "If true, use the online spherical harmonics method to calculate"//& + " self-attraction and loading.", default=.false.) + ! This is a more of a hard obsolete but should only impact a handful of users. + call obsolete_logical(param_file, "TIDAL_SAL_SHT", warning_val=CS%use_sal_sht, & + hint="Use USE_SAL_HARMONICS instead.") call get_param(param_file, mdl, "CALCULATE_SAL", calculate_sal, & "If true, calculate self-attraction and loading.", default=tides) - - ! ! Default USE_SAL is TRUE for now to keep backward compatibility with old MOM_INPUT files. It should be changed to - ! ! FALSE in the future (mostly to avoid the SSH calculations in MOM_PressureForce). In that case, the following check - ! ! informs prior tidal experiments that use scalar or iterative SAL to include USE_SAL flag, as the USE_SAL flag - ! ! overrules the option flags. - ! if ((.not. calculate_sal) .and. (CS%use_prev_tides .or. CS%use_sal_scalar .or. CS%use_sal_sht)) & - ! call MOM_error(FATAL, trim(mdl)//": USE_SAL is False but one of the options is True. Nothing will happen.") + if ((.not. calculate_sal) .and. (CS%use_tidal_sal_prev .or. CS%use_sal_scalar .or. CS%use_sal_sht)) & + call MOM_error(FATAL, trim(mdl)//": CALCULATE_SAL is False but one of the options is True.") + + ! TIDE_SAL_SCALAR_VALUE is going to be replaced by SAL_SCALAR_VALUE. The following segment of codes + ! should eventually be replaced by the commented code below. + ! if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) & + ! call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & + ! "The constant of proportionality between sea surface "//& + ! "height (really it should be bottom pressure) anomalies "//& + ! "and bottom geopotential anomalies. This is only used if "//& + ! "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + ! fail_if_missing=.true., units="m m-1") + ! endif + if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + CS%sal_scalar_value = -9e35 + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, "", do_not_log=.True.) + if (CS%sal_scalar_value == -9e35) then + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar_value, do_not_log=.True.) + if (CS%sal_scalar_value /= -9e35) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead.") + endif + if (CS%sal_scalar_value == -9e35) & + call MOM_error(FATAL, trim(mdl)//": USE_SAL_SCALAR is true but SAL_SCALAR_VALUE is not set.") + call log_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", units="m m-1") + endif if (CS%use_sal_sht) then - call get_param(param_file, mdl, "TIDAL_SAL_SHT_DEGREE", CS%sal_sht_Nd, & + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & "The maximum degree of the spherical harmonics transformation used for "// & "calculating the self-attraction and loading term.", & - default=0, do_not_log=.not. CS%use_sal_sht) - call get_param(param_file, mdl, "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) + default=0) + call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", warning_val=CS%sal_sht_Nd, & + hint="Use SAL_HARMONICS_DEGREE instead.") + call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) call get_param(param_file, mdl, "RHO_E", rhoE, & "The mean solid earth density. This is used for calculating the "// & "self-attraction and loading term.", units="kg m-3", & - default=5517.0, scale=US%kg_m3_to_R, do_not_log=.not. CS%use_sal_sht) + default=5517.0, scale=US%kg_m3_to_R) lmax = calc_lmax(CS%sal_sht_Nd) allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 @@ -235,10 +272,10 @@ end subroutine SAL_end !! !! This module contains methods to calculate self-attraction and loading (SAL) as a function of sea surface height (SSH) !! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or -!! storm surges, but the effect applys to all motions. +!! storm surges, but the effect applies to all motions. !! -!! If TIDE_USE_SAL_SCALAR is true, a scalar approximiation is applied (Accad and Pekeris 1978) and the SAL is simply -!! a fraction (set by TIDE_SAL_SCALAR_VALUE, usualy around 10% for global tides) of local SSH . For the tides, the +!! If TIDE_USE_SAL_SCALAR is true, a scalar approximation is applied (Accad and Pekeris 1978) and the SAL is simply +!! a fraction (set by TIDE_SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For the tides, the !! scalar approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, !! Arbic et al. (2004)]. !! diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index fcd90a4171..38286f20c5 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -33,10 +33,10 @@ module MOM_tidal_forcing !> The control structure for the MOM_tidal_forcing module type, public :: tidal_forcing_CS ; private - logical :: tidal_sal_from_file !< If true, Read the tidal self-attraction + logical :: use_tidal_sal_file !< If true, Read the tidal self-attraction !! and loading from input files, specified !! by TIDAL_INPUT_FILE. - logical :: use_prev_tides !< If true, use the SAL from the previous + logical :: use_tidal_sal_prev !< If true, use the SAL from the previous !! iteration of the tides to facilitate convergence. logical :: use_eq_phase !< If true, tidal forcing is phase-shifted to match !! equilibrium tide. Set to false if providing tidal phases @@ -344,22 +344,18 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) return endif - call get_param(param_file, mdl, "TIDAL_SAL_FROM_FILE", CS%tidal_sal_from_file, & + call get_param(param_file, mdl, "TIDAL_SAL_FROM_FILE", CS%use_tidal_sal_file, & "If true, read the tidal self-attraction and loading "//& "from input files, specified by TIDAL_INPUT_FILE. "//& "This is only used if TIDES is true.", default=.false.) - call get_param(param_file, mdl, "USE_PREVIOUS_TIDES", CS%use_prev_tides, & + call get_param(param_file, mdl, "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & "If true, use the SAL from the previous iteration of the "//& "tides to facilitate convergent iteration. "//& "This is only used if TIDES is true.", default=.false.) ! If it is being used, sal_scalar MUST be specified in param_file. - if (CS%use_prev_tides) & - call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & - "The constant of proportionality between sea surface "//& - "height (really it should be bottom pressure) anomalies "//& - "and bottom geopotential anomalies. This is only used if "//& - "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & - fail_if_missing=.true.) + if (CS%use_tidal_sal_prev) & + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, fail_if_missing=.true., & + do_not_log=.True.) if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & @@ -369,7 +365,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) do c=1,4*MAX_CONSTITUENTS ; tidal_input_files(c) = "" ; enddo - if (CS%tidal_sal_from_file .or. CS%use_prev_tides) then + if (CS%use_tidal_sal_file .or. CS%use_tidal_sal_prev) then call get_param(param_file, mdl, "TIDAL_INPUT_FILE", tidal_input_files, & "A list of input files for tidal information.", & default="", fail_if_missing=.true.) @@ -484,7 +480,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) " are true.", units="radians", default=phase0_def(c)) enddo - if (CS%tidal_sal_from_file) then + if (CS%use_tidal_sal_file) then allocate(CS%cosphasesal(isd:ied,jsd:jed,nc)) allocate(CS%sinphasesal(isd:ied,jsd:jed,nc)) allocate(CS%ampsal(isd:ied,jsd:jed,nc)) @@ -502,7 +498,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) enddo endif - if (CS%USE_PREV_TIDES) then + if (CS%use_tidal_sal_prev) then allocate(CS%cosphase_prev(isd:ied,jsd:jed,nc)) allocate(CS%sinphase_prev(isd:ied,jsd:jed,nc)) allocate(CS%amp_prev(isd:ied,jsd:jed,nc)) @@ -601,7 +597,7 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) enddo ; enddo enddo - if (CS%tidal_sal_from_file) then ; do c=1,CS%nc + if (CS%use_tidal_sal_file) then ; do c=1,CS%nc cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -610,7 +606,7 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) enddo ; enddo enddo ; endif - if (CS%USE_PREV_TIDES) then ; do c=1,CS%nc + if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 From 00a63e8484ba0a1eb978485c49bd479347170750 Mon Sep 17 00:00:00 2001 From: He Wang Date: Fri, 16 Jun 2023 15:07:57 -0400 Subject: [PATCH 072/146] Recover old answers with tides in Boussinesq mode This commit addresses the issue of bit level answer change with tides in Boussinesq mode. * A runtime parameter TIDES_ANSWER_DATE is added to restore old answers before the SAL module is added. The answer change is due to an reorder of summations of the SAL and tidal forcing terms. * The new version flag only applies to the analytical pressure force in Boussinesq mode, which is virtually the only configuration widely used and included in the test suite. * For Montgomery pressure and non-Boussinesq mode, the code is refactored in a more readable way. --- src/core/MOM_PressureForce_FV.F90 | 55 ++++++++---- src/core/MOM_PressureForce_Montgomery.F90 | 49 ++++++----- .../lateral/MOM_tidal_forcing.F90 | 83 +++++++++++++++++++ 3 files changed, 149 insertions(+), 38 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 25301ae31d..4314c1f7df 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -11,6 +11,7 @@ module MOM_PressureForce_FV use MOM_PressureForce_Mont, only : set_pbce_Bouss, set_pbce_nonBouss use MOM_self_attr_load, only : calc_SAL, SAL_CS use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_tidal_forcing, only : calc_tidal_forcing_legacy use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -62,6 +63,7 @@ module MOM_PressureForce_FV !! By the default (1) is for a piecewise linear method logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF + integer :: tide_answer_date !< Recover old answers with tides in Boussinesq mode integer :: id_e_tide = -1 !< Diagnostic identifier integer :: id_e_tide_eq = -1 !< Diagnostic identifier integer :: id_e_tide_sal = -1 !< Diagnostic identifier @@ -309,34 +311,27 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo enddo - ! The following two if-statements are arranged in a way that answers are not - ! changed from old versions in which SAL is part of the tidal forcing module. + ! Calculate and add the self-attraction and loading geopotential anomaly. if (CS%calculate_SAL) then - ! Find and add the self-attraction and loading geopotential anomaly. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & - max(-G%bathyT(i,j)-G%Z_ref, 0.0) enddo ; enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - else + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal(i,j) = 0.0 + za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) enddo ; enddo endif + ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then - ! Find and add the tidal geopotential anomaly. call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j)) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) + za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo endif @@ -472,7 +467,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in depth units [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: & - e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources ! [Z ~> m]. e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading @@ -560,6 +556,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! The following two if-statements are arranged in a way that answers are not ! changed from old versions in which SAL is part of the tidal forcing module. + + ! Calculate and add the self-attraction and loading geopotential anomaly. if (CS%calculate_SAL) then ! Determine the surface height anomaly for calculating self attraction ! and loading. This should really be based on bottom pressure anomalies, @@ -582,11 +580,21 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo endif + ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + if (CS%tide_answer_date>20230630) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_tide(i,j) = e_sal(i,j) + (e_tide_eq(i,j) + e_tide_sal(i,j)) + enddo ; enddo + else + call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, & + G, US, CS%tides_CSp) + endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))) + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal_tide(i,j)) enddo ; enddo else !$OMP parallel do default(shared) @@ -787,12 +795,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif if (present(eta)) then - if (CS%tides) then ! eta is the sea surface height relative to a time-invariant geoid, for comparison with ! what is used for eta in btstep. See how e was calculated about 200 lines above. + if (CS%tides) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal_tide(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) @@ -841,7 +849,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. ! New diagnostics are given for each individual field. - if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal_tide, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) @@ -867,6 +875,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, ! Local variables real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] + integer :: default_answer_date ! Global answer date ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -888,6 +897,16 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + if (CS%tides .and. GV%Boussinesq) then + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tide_answer_date, & + "The vintage of self-attraction and loading (SAL) and tidal forcing calculations in "//& + "Boussinesq mode. Values below 20230701 recover the old answers in which the SAL is "//& + "part of the tidal forcing calculation. The change is due to a reordered summation "//& + "and the difference is only at bit level.", default=20230630) + endif call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=CS%tides) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 53f6a5a925..a22c73fa4d 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -186,6 +186,12 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif endif + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + geopot_bot(i,j) = -GV%g_Earth * G%bathyT(i,j) + enddo ; enddo + + ! Calculate and add the self-attraction and loading geopotential anomaly. if (CS%calculate_SAL) then ! Determine the sea surface height anomalies, to enable the calculation ! of self-attraction and loading. @@ -209,23 +215,20 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb SSH(i,j) = SSH(i,j) + GV%H_to_RZ * h(i,j,k) * alpha_Lay(k) enddo ; enddo ; enddo endif + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - else + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal(i,j) = 0.0 + geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*e_sal(i,j) enddo ; enddo endif + ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j) + G%bathyT(i,j)) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + G%bathyT(i,j)) + geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*(e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo endif @@ -460,7 +463,12 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, I_Rho0 = 1.0/CS%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -G%bathyT(i,j) + enddo ; enddo + ! Calculate and add the self-attraction and loading geopotential anomaly. if (CS%calculate_SAL) then ! Determine the surface height anomaly for calculating self attraction ! and loading. This should really be based on bottom pressure anomalies, @@ -474,22 +482,18 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, enddo ; enddo enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - else + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal(i,j) = 0.0 + e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) enddo ; enddo endif + ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) + e(i,j,nz+1) = e(i,j,nz+1) - (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo endif @@ -608,18 +612,23 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, endif ! use_EOS if (present(eta)) then - if (CS%tides) then ! eta is the sea surface height relative to a time-invariant geoid, for ! comparison with what is used for eta in btstep. See how e was calculated ! about 200 lines above. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%Z_to_H + enddo ; enddo + if (CS%tides) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j)+e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H + eta(i,j) = eta(i,j) + (e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H enddo ; enddo - else + endif + if (CS%calculate_SAL) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + e_sal(i,j)*GV%Z_to_H + eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H enddo ; enddo endif endif diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 38286f20c5..948a39f2dc 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -16,6 +16,7 @@ module MOM_tidal_forcing implicit none ; private public calc_tidal_forcing, tidal_forcing_init, tidal_forcing_end +public calc_tidal_forcing_legacy ! MOM_open_boundary uses the following to set tides on the boundary. public astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency @@ -619,6 +620,88 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) end subroutine calc_tidal_forcing +!> This subroutine functions the same as calc_tidal_forcing but outputs a field that combines +!! previously calculated self-attraction and loading (SAL) and tidal forcings, so that old answers +!! can be preserved bitwise before SAL is separated out as an individual module. +subroutine calc_tidal_forcing_legacy(Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< The time for the caluculation. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: e_sal !< The self-attraction and loading fields + !! calculated previously used to + !! initialized e_sal_tide [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_sal_tide !< The total geopotential height anomalies + !! due to both SAL and tidal forcings [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_eq !< The geopotential height anomalies + !! due to the equilibrium tides [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_sal !< The geopotential height anomalies + !! due to the tidal SAL [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a + !! previous call to tidal_forcing_init. + + ! Local variables + real :: now ! The relative time compared with the tidal reference [T ~> s] + real :: amp_cosomegat, amp_sinomegat ! The tidal amplitudes times the components of phase [Z ~> m] + real :: cosomegat, sinomegat ! The components of the phase [nondim] + real :: amp_cossin ! A temporary field that adds cosines and sines [nondim] + integer :: i, j, c, m, is, ie, js, je, Isq, Ieq, Jsq, Jeq + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + call cpu_clock_begin(id_clock_tides) + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_tide(i,j) = 0.0 + e_tide_eq(i,j) = 0.0 + e_tide_sal(i,j) = 0.0 + enddo ; enddo + + if (CS%nc == 0) then + return + endif + + now = US%s_to_T * time_type_to_real(Time - cs%time_ref) + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_tide(i,j) = e_sal(i,j) + enddo ; enddo + + do c=1,CS%nc + m = CS%struct(c) + amp_cosomegat = CS%amp(c)*CS%love_no(c) * cos(CS%freq(c)*now + CS%phase0(c)) + amp_sinomegat = CS%amp(c)*CS%love_no(c) * sin(CS%freq(c)*now + CS%phase0(c)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + amp_cossin = (amp_cosomegat*CS%cos_struct(i,j,m) + amp_sinomegat*CS%sin_struct(i,j,m)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_eq(i,j) = e_tide_eq(i,j) + amp_cossin + enddo ; enddo + enddo + + if (CS%use_tidal_sal_file) then ; do c=1,CS%nc + cosomegat = cos(CS%freq(c)*now) + sinomegat = sin(CS%freq(c)*now) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + amp_cossin = CS%ampsal(i,j,c) & + * (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_sal(i,j) = e_tide_sal(i,j) + amp_cossin + enddo ; enddo + enddo ; endif + + if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc + cosomegat = cos(CS%freq(c)*now) + sinomegat = sin(CS%freq(c)*now) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + amp_cossin = -CS%sal_scalar * CS%amp_prev(i,j,c) & + * (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_sal(i,j) = e_tide_sal(i,j) + amp_cossin + enddo ; enddo + enddo ; endif + call cpu_clock_end(id_clock_tides) + +end subroutine calc_tidal_forcing_legacy + !> This subroutine deallocates memory associated with the tidal forcing module. subroutine tidal_forcing_end(CS) type(tidal_forcing_CS), intent(inout) :: CS !< The control structure returned by a previous call From 3061166a1a19a52036aa007065f07dd2efd15b0e Mon Sep 17 00:00:00 2001 From: He Wang Date: Mon, 19 Jun 2023 22:15:43 -0400 Subject: [PATCH 073/146] Refactor SAL and tides calls in Boussinesq mode Consistent with the non-Boussinesq option with the new answer option --- src/core/MOM_PressureForce_FV.F90 | 133 ++++++++++++++++++++---------- 1 file changed, 89 insertions(+), 44 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 4314c1f7df..da94add51e 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -63,7 +63,7 @@ module MOM_PressureForce_FV !! By the default (1) is for a piecewise linear method logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF - integer :: tide_answer_date !< Recover old answers with tides in Boussinesq mode + integer :: tides_answer_date !< Recover old answers with tides in Boussinesq mode integer :: id_e_tide = -1 !< Diagnostic identifier integer :: id_e_tide_eq = -1 !< Diagnostic identifier integer :: id_e_tide_sal = -1 !< Diagnostic identifier @@ -554,53 +554,79 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm G_Rho0 = GV%g_Earth / GV%Rho0 rho_ref = CS%Rho0 - ! The following two if-statements are arranged in a way that answers are not - ! changed from old versions in which SAL is part of the tidal forcing module. + if (CS%tides_answer_date>20230630) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -G%bathyT(i,j) + enddo ; enddo - ! Calculate and add the self-attraction and loading geopotential anomaly. - if (CS%calculate_SAL) then - ! Determine the surface height anomaly for calculating self attraction - ! and loading. This should really be based on bottom pressure anomalies, - ! but that is not yet implemented, and the current form is correct for - ! barotropic tides. - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 - do i=Isq,Ieq+1 - SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then + ! Determine the surface height anomaly for calculating self attraction + ! and loading. This should really be based on bottom pressure anomalies, + ! but that is not yet implemented, and the current form is correct for + ! barotropic tides. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) + enddo + do k=1,nz ; do i=Isq,Ieq+1 + SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z + enddo ; enddo enddo - do k=1,nz ; do i=Isq,Ieq+1 - SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) enddo ; enddo - enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal(i,j) = 0.0 - enddo ; enddo - endif + endif - ! Calculate and add the tidal geopotential anomaly. - if (CS%tides) then - if (CS%tide_answer_date>20230630) then + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal_tide(i,j) = e_sal(i,j) + (e_tide_eq(i,j) + e_tide_sal(i,j)) + e(i,j,nz+1) = e(i,j,nz+1) - (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo + endif + else ! Old answers + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then + ! Determine the surface height anomaly for calculating self attraction + ! and loading. This should really be based on bottom pressure anomalies, + ! but that is not yet implemented, and the current form is correct for + ! barotropic tides. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) + enddo + do k=1,nz ; do i=Isq,Ieq+1 + SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z + enddo ; enddo + enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo + endif + + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, & G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal_tide(i,j)) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) + enddo ; enddo endif - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal_tide(i,j)) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) - enddo ; enddo endif !$OMP parallel do default(shared) @@ -797,16 +823,35 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (present(eta)) then ! eta is the sea surface height relative to a time-invariant geoid, for comparison with ! what is used for eta in btstep. See how e was calculated about 200 lines above. - if (CS%tides) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal_tide(i,j))*GV%Z_to_H - enddo ; enddo - else + if (CS%tides_answer_date>20230630) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = (e(i,j,1) + e_sal(i,j))*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H enddo ; enddo + if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + (e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H + enddo ; enddo + endif + if (CS%calculate_SAL) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H + enddo ; enddo + endif + else ! Old answers + if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal_tide(i,j))*GV%Z_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = (e(i,j,1) + e_sal(i,j))*GV%Z_to_H + enddo ; enddo + endif endif endif @@ -901,7 +946,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tide_answer_date, & + call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tides_answer_date, & "The vintage of self-attraction and loading (SAL) and tidal forcing calculations in "//& "Boussinesq mode. Values below 20230701 recover the old answers in which the SAL is "//& "part of the tidal forcing calculation. The change is due to a reordered summation "//& From 3515b804ecb0c98f06b50a56ab95d997efc78a69 Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 17 Aug 2023 01:30:25 -0400 Subject: [PATCH 074/146] Change SAL related parameter names This commit revises changes of some parameter names from a previous commit. * Logical switch TIDE_USE_SAL_SCALAR is obsolete and replaced by SAL_SCALAR_APPROX. * TIDE_SAL_SCALAR_VALUE is replaced by SAL_SCALAR_VALUE. The old parameter name is still accepted but a warning is given. * Logical switch TIDAL_SAL_SHT is obsolete and replaced by SAL_HARMONICS. * TIDAL_SAL_SHT_DEGREE is obsolete and replaced by SAL_HARMONICS_DEGREE. * RHO_E is replaced by RHO_SOLID_EARTH. --- src/diagnostics/MOM_obsolete_params.F90 | 5 ++ .../lateral/MOM_self_attr_load.F90 | 86 ++++++------------- .../lateral/MOM_spherical_harmonics.F90 | 11 +-- .../lateral/MOM_tidal_forcing.F90 | 2 +- 4 files changed, 38 insertions(+), 66 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 21a09dfdbb..7614eb210c 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -111,6 +111,11 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "SMOOTH_RI", hint="Instead use N_SMOOTH_RI.") + call obsolete_logical(param_file, "TIDE_USE_SAL_SCALAR", hint="Use SAL_SCALAR_APPROX instead.") + call obsolete_logical(param_file, "TIDAL_SAL_SHT", hint="Use SAL_HARMONICS instead.") + call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", hint="Use SAL_HARMONICS_DEGREE instead.") + call obsolete_real(param_file, "RHO_E", hint="Use RHO_SOLID_EARTH instead.") + ! Write the file version number to the model log. call log_version(param_file, mdl, version) diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index be45f64cfe..fa5d973989 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -3,7 +3,7 @@ module MOM_self_attr_load use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_obsolete_params, only : obsolete_logical, obsolete_int use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type @@ -169,6 +169,10 @@ subroutine SAL_init(G, US, param_file, CS) call log_version(param_file, mdl, version, "") call get_param(param_file, '', "TIDES", tides, default=.false., do_not_log=.True.) + call get_param(param_file, mdl, "CALCULATE_SAL", calculate_sal, "If true, calculate "//& + " self-attraction and loading.", default=tides, do_not_log=.True.) + if (.not. calculate_sal) return + if (tides) then call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & default=.false., do_not_log=.True.) @@ -176,73 +180,39 @@ subroutine SAL_init(G, US, param_file, CS) default=.false., do_not_log=.True.) endif - ! TIDE_USE_SAL_SCALAR is going to be replaced by USE_SAL_SCALAR. During the transition, the default of - ! USE_SAL_SCALAR is set to be consistent with TIDE_USE_SAL_SCALAR before the implementation of spherical - ! harmonics SAL. - ! A FATAL error is only issued when the user specified TIDE_USE_SAL_SCALAR contradicts USE_SAL_SCALAR. - call get_param(param_file, mdl, "USE_SAL_SCALAR", CS%use_sal_scalar, & + call get_param(param_file, mdl, "SAL_SCALAR_APPROX", CS%use_sal_scalar, & "If true, use the scalar approximation to calculate self-attraction and"//& - " loading. This parameter is to replace TIDE_USE_SAL_SCALAR, as SAL applies"//& - " to all motions. When both USE_SAL_SCALAR and TIDE_USE_SAL_SCALAR are"//& - " specified, USE_SAL_SCALAR overrides TIDE_USE_SAL_SCALAR.", & - default=tides .and. (.not.use_tidal_sal_file)) - if (tides) then - call obsolete_logical(param_file, "TIDE_USE_SAL_SCALAR", warning_val=CS%use_sal_scalar, & - hint="Use USE_SAL_SCALAR instead.") - endif - - call get_param(param_file, mdl, "USE_SAL_HARMONICS", CS%use_sal_sht, & + " loading.", default=tides .and. (.not.use_tidal_sal_file)) + call get_param(param_file, mdl, "SAL_HARMONICS", CS%use_sal_sht, & "If true, use the online spherical harmonics method to calculate"//& " self-attraction and loading.", default=.false.) - ! This is a more of a hard obsolete but should only impact a handful of users. - call obsolete_logical(param_file, "TIDAL_SAL_SHT", warning_val=CS%use_sal_sht, & - hint="Use USE_SAL_HARMONICS instead.") - - call get_param(param_file, mdl, "CALCULATE_SAL", calculate_sal, & - "If true, calculate self-attraction and loading.", default=tides) - if ((.not. calculate_sal) .and. (CS%use_tidal_sal_prev .or. CS%use_sal_scalar .or. CS%use_sal_sht)) & - call MOM_error(FATAL, trim(mdl)//": CALCULATE_SAL is False but one of the options is True.") - - ! TIDE_SAL_SCALAR_VALUE is going to be replaced by SAL_SCALAR_VALUE. The following segment of codes - ! should eventually be replaced by the commented code below. - ! if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) & - ! call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & - ! "The constant of proportionality between sea surface "//& - ! "height (really it should be bottom pressure) anomalies "//& - ! "and bottom geopotential anomalies. This is only used if "//& - ! "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & - ! fail_if_missing=.true., units="m m-1") - ! endif + if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then - CS%sal_scalar_value = -9e35 - call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, "", do_not_log=.True.) - if (CS%sal_scalar_value == -9e35) then - call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar_value, do_not_log=.True.) - if (CS%sal_scalar_value /= -9e35) & - call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& - "Use SAL_SCALAR_VALUE instead.") - endif - if (CS%sal_scalar_value == -9e35) & - call MOM_error(FATAL, trim(mdl)//": USE_SAL_SCALAR is true but SAL_SCALAR_VALUE is not set.") - call log_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & + units="m m-1", default=0.0, do_not_log=.True.) + if (tide_sal_scalar_value/=0.0) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead." ) + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & "The constant of proportionality between sea surface "//& "height (really it should be bottom pressure) anomalies "//& "and bottom geopotential anomalies. This is only used if "//& - "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", units="m m-1") + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + default=tide_sal_scalar_value, units="m m-1", & + do_not_log=(.not. CS%use_sal_scalar) .and. (.not. CS%use_tidal_sal_prev)) endif if (CS%use_sal_sht) then call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & "The maximum degree of the spherical harmonics transformation used for "// & "calculating the self-attraction and loading term.", & - default=0) - call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", warning_val=CS%sal_sht_Nd, & - hint="Use SAL_HARMONICS_DEGREE instead.") - call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) - call get_param(param_file, mdl, "RHO_E", rhoE, & + default=0, do_not_log=.not.CS%use_sal_sht) + call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, & + units="kg m-3", do_not_log=.True.) + call get_param(param_file, mdl, "RHO_SOLID_EARTH", rhoE, & "The mean solid earth density. This is used for calculating the "// & "self-attraction and loading term.", units="kg m-3", & - default=5517.0, scale=US%kg_m3_to_R) + default=5517.0, scale=US%kg_m3_to_R, do_not_log=.not. CS%use_sal_sht) lmax = calc_lmax(CS%sal_sht_Nd) allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 @@ -274,14 +244,14 @@ end subroutine SAL_end !! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or !! storm surges, but the effect applies to all motions. !! -!! If TIDE_USE_SAL_SCALAR is true, a scalar approximation is applied (Accad and Pekeris 1978) and the SAL is simply -!! a fraction (set by TIDE_SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For the tides, the -!! scalar approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, +!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (Accad and Pekeris 1978) and the SAL is simply +!! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For tides, the scalar +!! approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, !! Arbic et al. (2004)]. !! -!! If TIDAL_SAL_SHT is true, a more accurate online spherical harmonic transforms are used to calculate SAL. +!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate SAL. !! Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set by -!! TIDAL_SAL_SHT_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean +!! SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean !! developed by Los Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. !! !! References: diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index b20df036e0..2a72d26a20 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -217,7 +217,7 @@ subroutine spherical_harmonics_init(G, param_file, CS) integer :: is, ie, js, je integer :: i, j, k integer :: m, n - integer :: Nd_tidal_SAL ! Maximum degree for tidal SAL + integer :: Nd_SAL ! Maximum degree for SAL ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_spherical_harmonics" ! This module's name. @@ -228,11 +228,8 @@ subroutine spherical_harmonics_init(G, param_file, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "TIDAL_SAL_SHT_DEGREE", Nd_tidal_SAL, & - "The maximum degree of the spherical harmonics transformation used for "// & - "calculating the self-attraction and loading term for tides.", & - default=0, do_not_log=.true.) - CS%ndegree = Nd_tidal_SAL + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", Nd_SAL, "", default=0, do_not_log=.true.) + CS%ndegree = Nd_SAL CS%lmax = calc_lmax(CS%ndegree) call get_param(param_file, mdl, "SHT_REPRODUCING_SUM", CS%reprod_sum, & "If true, use reproducing sums (invariant to PE layout) in inverse transform "// & @@ -361,7 +358,7 @@ end function order2index !! array vectorization. !! !! The maximum degree of the spherical harmonics is a runtime parameter and the maximum used by all SHT applications. -!! At the moment, it is only decided by TIDAL_SAL_SHT_DEGREE. +!! At the moment, it is only decided by SAL_HARMONICS_DEGREE. !! !! The forward transforms involve a global summation. Runtime flag SHT_REPRODUCING_SUM controls whether this is done !! in a bit-wise reproducing way or not. diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 948a39f2dc..1ef55fff7f 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -356,7 +356,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) ! If it is being used, sal_scalar MUST be specified in param_file. if (CS%use_tidal_sal_prev) & call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, fail_if_missing=.true., & - do_not_log=.True.) + units="m m-1", do_not_log=.True.) if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & From c6b6143373daf3cb13ecfea8e92f11a72d616f69 Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 17 Aug 2023 14:46:21 -0400 Subject: [PATCH 075/146] Modify reading SAL related parameters * An incident of incorrect indent is fixed in SAL_int. * Parameters read in SAL_int is moved out from if statements. DO_NOT_LOG is used to prevent logging unused parameters. * Reading SAL_SCALAR_VALUE in tidal_forcing_init is now consistent with SAL_init. * Some unused variables in tidal_forcing_init are removed. --- .../lateral/MOM_self_attr_load.F90 | 55 +++++++++---------- .../lateral/MOM_tidal_forcing.F90 | 20 ++++--- 2 files changed, 39 insertions(+), 36 deletions(-) diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index fa5d973989..20d239eb53 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -181,38 +181,35 @@ subroutine SAL_init(G, US, param_file, CS) endif call get_param(param_file, mdl, "SAL_SCALAR_APPROX", CS%use_sal_scalar, & - "If true, use the scalar approximation to calculate self-attraction and"//& - " loading.", default=tides .and. (.not.use_tidal_sal_file)) + "If true, use the scalar approximation to calculate self-attraction and "//& + "loading.", default=tides .and. (.not. use_tidal_sal_file)) + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & + units="m m-1", default=0.0, do_not_log=.True.) + if (tide_sal_scalar_value/=0.0) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead." ) + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + default=tide_sal_scalar_value, units="m m-1", & + do_not_log=(.not. CS%use_sal_scalar) .and. (.not. CS%use_tidal_sal_prev)) call get_param(param_file, mdl, "SAL_HARMONICS", CS%use_sal_sht, & - "If true, use the online spherical harmonics method to calculate"//& - " self-attraction and loading.", default=.false.) - - if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then - call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & - units="m m-1", default=0.0, do_not_log=.True.) - if (tide_sal_scalar_value/=0.0) & - call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& - "Use SAL_SCALAR_VALUE instead." ) - call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & - "The constant of proportionality between sea surface "//& - "height (really it should be bottom pressure) anomalies "//& - "and bottom geopotential anomalies. This is only used if "//& - "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & - default=tide_sal_scalar_value, units="m m-1", & - do_not_log=(.not. CS%use_sal_scalar) .and. (.not. CS%use_tidal_sal_prev)) - endif + "If true, use the online spherical harmonics method to calculate "//& + "self-attraction and loading.", default=.false.) + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & + "The maximum degree of the spherical harmonics transformation used for "// & + "calculating the self-attraction and loading term.", & + default=0, do_not_log=(.not. CS%use_sal_sht)) + call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, & + units="kg m-3", do_not_log=.True.) + call get_param(param_file, mdl, "RHO_SOLID_EARTH", rhoE, & + "The mean solid earth density. This is used for calculating the "// & + "self-attraction and loading term.", units="kg m-3", & + default=5517.0, scale=US%kg_m3_to_R, do_not_log=(.not. CS%use_sal_sht)) if (CS%use_sal_sht) then - call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & - "The maximum degree of the spherical harmonics transformation used for "// & - "calculating the self-attraction and loading term.", & - default=0, do_not_log=.not.CS%use_sal_sht) - call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, & - units="kg m-3", do_not_log=.True.) - call get_param(param_file, mdl, "RHO_SOLID_EARTH", rhoE, & - "The mean solid earth density. This is used for calculating the "// & - "self-attraction and loading term.", units="kg m-3", & - default=5517.0, scale=US%kg_m3_to_R, do_not_log=.not. CS%use_sal_sht) lmax = calc_lmax(CS%sal_sht_Nd) allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 1ef55fff7f..eb481f2131 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -256,10 +256,8 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. character(len=128) :: mesg character(len=200) :: tidal_input_files(4*MAX_CONSTITUENTS) + real :: tide_sal_scalar_value integer :: i, j, c, is, ie, js, je, isd, ied, jsd, jed, nc - integer :: lmax ! Total modes of the real spherical harmonics [nondim] - real :: rhoW ! The average density of sea water [R ~> kg m-3]. - real :: rhoE ! The average density of Earth [R ~> kg m-3]. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd; jed = G%jed @@ -353,10 +351,18 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) "If true, use the SAL from the previous iteration of the "//& "tides to facilitate convergent iteration. "//& "This is only used if TIDES is true.", default=.false.) - ! If it is being used, sal_scalar MUST be specified in param_file. - if (CS%use_tidal_sal_prev) & - call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, fail_if_missing=.true., & - units="m m-1", do_not_log=.True.) + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & + units="m m-1", default=0.0, do_not_log=.True.) + if (tide_sal_scalar_value/=0.0) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead." ) + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + default=tide_sal_scalar_value, units="m m-1", & + do_not_log=(.not. CS%use_tidal_sal_prev)) if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & From 095a3b5fe7a60a2eb796232d0c97ea345ef1b87e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 22 Aug 2023 16:44:30 -0400 Subject: [PATCH 076/146] *+Use TIDES_ANSWER_DATE with semi-Boussinesq tides Use TIDES_ANSWER_DATE with an additional if-block to recover the dev/gfdl answers in semi-Boussinesq mode runs with tides enabled, similarly to what is already being done in Boussinesq mode. This changes some answers for the nonBous_global and tides_025 test cases back to those that would be obtained with the code on dev/gfdl. TIDES_ANSWER_DATE is now logged in all cases with tides, so the MOM_parameter_doc files change in some non-Boussinesq cases. --- src/core/MOM_PressureForce_FV.F90 | 33 +++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index da94add51e..64df200f31 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -127,6 +127,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading ! specific to tides [Z ~> m]. + e_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. dM, & ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the @@ -320,19 +321,31 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) - enddo ; enddo + if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq) .or. (.not.CS%tides)) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) + enddo ; enddo + endif endif ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) - enddo ; enddo + if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq)) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) + enddo ; enddo + else ! This block recreates older answers with tides. + if (.not.CS%calculate_SAL) e_sal(:,:) = 0.0 + call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, & + G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth * e_sal_tide(i,j) + enddo ; enddo + endif endif if (CS%GFS_scale < 1.0) then @@ -942,7 +955,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) - if (CS%tides .and. GV%Boussinesq) then + if (CS%tides) then call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) From 24160d59976e87c2aeef68238a0d34b5d46b9e10 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 15 Aug 2023 09:26:42 -0400 Subject: [PATCH 077/146] *Non-Boussinesq revision of MOM.F90 for restarts This commit revises the internal code in step_MOM and extract_surface_state to work in fully non-Boussinesq mode without any dependencies on the Boussinesq reference density and provide updates needed to reproduce answers across restarts in non-Boussinesq mode. The subroutine calls from this module have already been revised, so only this file needs to be updated. The specific changes include: - Rescaled the nominal mixed layer depth variables HFREEZE, HMIX_SFC_PROP and HMIX_UV_SFC_PROP for determining surface properties to eliminate unit conversion factors during the run. This changes the units of 3 elements of the MOM_control_struct and one internal variable and adds 3 new internal variables. - Call calc_derived_thermo to update SpV_avg at the start of step_MOM if the internal ocean state depends on the surface pressure and that surface pressure has been passed in from the driver. There are 3 new internal variables and in some cases a new blocking halo update to enable these changes. All Boussinesq solutions are bitwise identical with this commit. It changes answers in some non-Boussinesq fully coupled or ice-ocean configurations. Other non-Boussinesq mode cases are mathematically equivalent in the case where RHO_0 = RHO_KV_CONVERT and bitwise identical if RHO_KV_CONVERT is an integer power of 2. This commit corrects issues with reproducability across restarts in the non-Boussinesq cases where the answer changes. --- src/core/MOM.F90 | 87 ++++++++++++++++++++++++++++++++++-------------- 1 file changed, 62 insertions(+), 25 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c9b8ea42c0..e59c9ac60a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -337,14 +337,14 @@ module MOM ! These elements are used to control the calculation and error checking of the surface state real :: Hmix !< Diagnostic mixed layer thickness over which to !! average surface tracer properties when a bulk - !! mixed layer is not used [Z ~> m], or a negative value + !! mixed layer is not used [H ~> m or kg m-2], or a negative value !! if a bulk mixed layer is being used. - real :: HFrz !< If HFrz > 0, the nominal depth over which melt potential is - !! computed [Z ~> m]. The actual depth over which melt potential is + real :: HFrz !< If HFrz > 0, the nominal depth over which melt potential is computed + !! [H ~> m or kg m-2]. The actual depth over which melt potential is !! computed is min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. real :: Hmix_UV !< Depth scale over which to average surface flow to - !! feedback to the coupler/driver [Z ~> m] when + !! feedback to the coupler/driver [H ~> m or kg m-2] when !! bulk mixed layer is not used, or a negative value !! if a bulk mixed layer is being used. logical :: check_bad_sfc_vals !< If true, scan surface state for ridiculous values. @@ -516,6 +516,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! various unit conversion factors integer :: ntstep ! time steps between tracer updates or diabatic forcing integer :: n_max ! number of steps to take in this call + integer :: halo_sz, dynamics_stencil integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -538,6 +539,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! multiple dynamic timesteps. logical :: do_dyn ! If true, dynamics are updated with this call. logical :: do_thermo ! If true, thermodynamics and remapping may be applied with this call. + logical :: nonblocking_p_surf_update ! A flag to indicate whether surface properties + ! can use nonblocking halo updates logical :: cycle_start ! If true, do calculations that are only done at the start of ! a stepping cycle (whatever that may mean). logical :: cycle_end ! If true, do calculations and diagnostics that are only done at @@ -647,13 +650,11 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt_therm = dt*ntstep endif - if (associated(forces%p_surf)) p_surf => forces%p_surf - if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. - CS%tv%p_surf => NULL() - if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) CS%tv%p_surf => forces%p_surf - !---------- Initiate group halo pass of the forcing fields call cpu_clock_begin(id_clock_pass) + nonblocking_p_surf_update = G%nonblocking_updates .and. & + .not.(CS%use_p_surf_in_EOS .and. associated(forces%p_surf) .and. & + allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) if (.not.associated(forces%taux) .or. .not.associated(forces%tauy)) & call MOM_error(FATAL,'step_MOM:forces%taux,tauy not associated') call create_group_pass(pass_tau_ustar_psurf, forces%taux, forces%tauy, G%Domain) @@ -663,12 +664,26 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call create_group_pass(pass_tau_ustar_psurf, forces%tau_mag, G%Domain) if (associated(forces%p_surf)) & call create_group_pass(pass_tau_ustar_psurf, forces%p_surf, G%Domain) - if (G%nonblocking_updates) then + if (nonblocking_p_surf_update) then call start_group_pass(pass_tau_ustar_psurf, G%Domain) else call do_group_pass(pass_tau_ustar_psurf, G%Domain) endif call cpu_clock_end(id_clock_pass) + + if (associated(forces%p_surf)) p_surf => forces%p_surf + if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. + CS%tv%p_surf => NULL() + if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) then + CS%tv%p_surf => forces%p_surf + + if (allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) then + ! The internal ocean state depends on the surface pressues, so update SpV_avg. + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) + endif + endif + else ! This step only updates the thermodynamics so setting timesteps is simpler. n_max = 1 @@ -687,7 +702,13 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS CS%tv%p_surf => NULL() if (CS%use_p_surf_in_EOS .and. associated(fluxes%p_surf)) then CS%tv%p_surf => fluxes%p_surf - if (allocated(CS%tv%SpV_avg)) call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) + if (allocated(CS%tv%SpV_avg)) then + call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) + ! The internal ocean state depends on the surface pressues, so update SpV_avg. + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + halo_sz = max(halo_sz, 1) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz, debug=CS%debug) + endif endif endif @@ -714,7 +735,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl) call update_stochastics(CS%stoch_CS) if (do_dyn) then - if (G%nonblocking_updates) & + if (nonblocking_p_surf_update) & call complete_group_pass(pass_tau_ustar_psurf, G%Domain, clock=id_clock_pass) if (CS%interp_p_surf) then @@ -1987,6 +2008,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & logical, allocatable, dimension(:,:,:) :: PCM_cell ! If true, PCM remapping should be used in a cell. type(group_pass_type) :: tmp_pass_uv_T_S_h, pass_uv_T_S_h + real :: Hmix_z, Hmix_UV_z ! Temporary variables with averaging depths [Z ~> m] + real :: HFrz_z ! Temporary variable with the melt potential depth [Z ~> m] real :: default_val ! default value for a parameter logical :: write_geom_files ! If true, write out the grid geometry files. logical :: new_sim ! If true, this has been determined to be a new simulation @@ -2223,22 +2246,23 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (bulkmixedlayer) then CS%Hmix = -1.0 ; CS%Hmix_UV = -1.0 else - call get_param(param_file, "MOM", "HMIX_SFC_PROP", CS%Hmix, & + call get_param(param_file, "MOM", "HMIX_SFC_PROP", Hmix_z, & "If BULKMIXEDLAYER is false, HMIX_SFC_PROP is the depth "//& "over which to average to find surface properties like "//& "SST and SSS or density (but not surface velocities).", & units="m", default=1.0, scale=US%m_to_Z) - call get_param(param_file, "MOM", "HMIX_UV_SFC_PROP", CS%Hmix_UV, & + call get_param(param_file, "MOM", "HMIX_UV_SFC_PROP", Hmix_UV_z, & "If BULKMIXEDLAYER is false, HMIX_UV_SFC_PROP is the depth "//& "over which to average to find surface flow properties, "//& "SSU, SSV. A non-positive value indicates no averaging.", & units="m", default=0.0, scale=US%m_to_Z) endif - call get_param(param_file, "MOM", "HFREEZE", CS%HFrz, & + call get_param(param_file, "MOM", "HFREEZE", HFrz_z, & "If HFREEZE > 0, melt potential will be computed. The actual depth "//& "over which melt potential is computed will be min(HFREEZE, OBLD), "//& "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& - "melt potential will not be computed.", units="m", default=-1.0, scale=US%m_to_Z) + "melt potential will not be computed.", & + units="m", default=-1.0, scale=US%m_to_Z) call get_param(param_file, "MOM", "INTERPOLATE_P_SURF", CS%interp_p_surf, & "If true, linearly interpolate the surface pressure "//& "over the coupling time step, using the specified value "//& @@ -2525,6 +2549,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call verticalGridInit( param_file, CS%GV, US ) GV => CS%GV + ! Now that the vertical grid has been initialized, rescale parameters that depend on factors + ! that are set with the vertical grid to their desired units. This added rescaling step would + ! be unnecessary if the vertical grid were initialized earlier in this routine. + if (.not.bulkmixedlayer) then + CS%Hmix = (US%Z_to_m * GV%m_to_H) * Hmix_z + CS%Hmix_UV = (US%Z_to_m * GV%m_to_H) * Hmix_UV_z + endif + CS%HFrz = (US%Z_to_m * GV%m_to_H) * HFrz_z + ! Shift from using the temporary dynamic grid type to using the final (potentially static) ! and properly rotated ocean-specific grid type and horizontal index type. if (CS%rotate_index) then @@ -3168,6 +3201,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! Update derived thermodynamic quantities. if (allocated(CS%tv%SpV_avg)) then + !### There may be a restart issue here with the surface pressure not being updated? call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif @@ -3415,7 +3449,7 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) do_not_log=.true.) if (use_ice_shelf .and. associated(CS%Hml)) then call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & - "Mixed layer thickness", "meter", conversion=US%Z_to_m) + "Mixed layer thickness", "m", conversion=US%Z_to_m) endif ! Register scalar unit conversion factors. @@ -3497,7 +3531,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ! After the ANSWERS_2018 flag has been obsoleted, H_rescale will be 1. real :: T_freeze(SZI_(CS%G)) !< freezing temperature [C ~> degC] real :: pres(SZI_(CS%G)) !< Pressure to use for the freezing temperature calculation [R L2 T-2 ~> Pa] - real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [Z C ~> m degC] + real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [H C ~> m degC or degC kg m-2] logical :: use_temperature !< If true, temperature and salinity are used as state variables. integer :: i, j, k, is, ie, js, je, nz, numberOfErrors, ig, jg integer :: isd, ied, jsd, jed @@ -3572,9 +3606,12 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo else ! (CS%Hmix >= 0.0) - H_rescale = 1.0 ; if (CS%answer_date < 20190101) H_rescale = GV%H_to_Z + H_rescale = 1.0 depth_ml = CS%Hmix - if (CS%answer_date >= 20190101) depth_ml = CS%Hmix*GV%Z_to_H + if (CS%answer_date < 20190101) then + H_rescale = GV%H_to_Z + depth_ml = GV%H_to_Z*CS%Hmix + endif ! Determine the mean tracer properties of the uppermost depth_ml fluid. !$OMP parallel do default(shared) private(depth,dh) @@ -3645,7 +3682,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ! This assumes that u and v halos have already been updated. if (CS%Hmix_UV>0.) then depth_ml = CS%Hmix_UV - if (CS%answer_date >= 20190101) depth_ml = CS%Hmix_UV*GV%Z_to_H + if (CS%answer_date < 20190101) depth_ml = GV%H_to_Z*CS%Hmix_UV !$OMP parallel do default(shared) private(depth,dh,hv) do J=js-1,ie do i=is,ie @@ -3719,9 +3756,9 @@ subroutine extract_surface_state(CS, sfc_state_in) do k=1,nz call calculate_TFreeze(CS%tv%S(is:ie,j,k), pres(is:ie), T_freeze(is:ie), CS%tv%eqn_of_state) do i=is,ie - depth_ml = min(CS%HFrz, CS%visc%MLD(i,j)) - if (depth(i) + h(i,j,k)*GV%H_to_Z < depth_ml) then - dh = h(i,j,k)*GV%H_to_Z + depth_ml = min(CS%HFrz, (US%Z_to_m*GV%m_to_H)*CS%visc%MLD(i,j)) + if (depth(i) + h(i,j,k) < depth_ml) then + dh = h(i,j,k) elseif (depth(i) < depth_ml) then dh = depth_ml - depth(i) else @@ -3743,7 +3780,7 @@ subroutine extract_surface_state(CS, sfc_state_in) if (G%mask2dT(i,j)>0.) then ! instantaneous melt_potential [Q R Z ~> J m-2] - sfc_state%melt_potential(i,j) = CS%tv%C_p * GV%Rho0 * delT(i) + sfc_state%melt_potential(i,j) = CS%tv%C_p * GV%H_to_RZ * delT(i) endif enddo enddo ! end of j loop From 1872d3b03d0c47b5b118f0cd50d3407efc40188b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Jul 2023 10:32:16 -0400 Subject: [PATCH 078/146] *Revise BFB_set_coord and BFB_buoyancy_forcing Revised BFB_set_coord and BFB_buoyancy_forcing to be consistent with other instances of a linear equation of state, and to set g_prime in non-Boussinesq mode similarly to how it is set in other places. Also use RESTORE_FLUX_RHO in place of RHO_0 when to specify the densities that are used to convert the piston velocities into restoring heat or salt fluxes with BFB_buoyancy_forcing, like in other places in the MOM6 code. This change will change answers by default when BFB_set_coord is used, but the old Boussinesq answers can be recovered by setting the reference salinity S_REF to 38.75 ppt or by setting RHO_T0_S0 to 1003.0 kg m-3. --- src/user/BFB_initialization.F90 | 31 ++++++++++++++++++++-------- src/user/BFB_surface_forcing.F90 | 35 ++++++++++++++++++++++++-------- 2 files changed, 48 insertions(+), 18 deletions(-) diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 3efc908ffb..67381bfdc5 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -38,8 +38,11 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + real :: Rho_T0_S0 ! The density at T=0, S=0 [R ~> kg m-3] real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] real :: SST_s, T_bot ! Temperatures at the surface and seafloor [C ~> degC] + real :: S_ref ! Reference salinity [S ~> ppt] real :: rho_top, rho_bot ! Densities at the surface and seafloor [R ~> kg m-3] integer :: k, nz ! This include declares and sets the variable "version". @@ -47,23 +50,33 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file) character(len=40) :: mdl = "BFB_initialization" ! This module's name. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "DRHO_DT", drho_dt, & - "Rate of change of density with temperature.", & - units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + "The partial derivative of density with temperature.", & + units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + "The partial derivative of density with salinity.", & + units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + call get_param(param_file, mdl, "RHO_T0_S0", Rho_T0_S0, & + "The density at T=0, S=0.", units="kg m-3", default=1000.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SST_S", SST_s, & - "SST at the southern edge of the domain.", units="degC", default=20.0, scale=US%degC_to_C) + "SST at the southern edge of the domain.", & + units="degC", default=20.0, scale=US%degC_to_C) call get_param(param_file, mdl, "T_BOT", T_bot, & "Bottom temperature", units="degC", default=5.0, scale=US%degC_to_C) - rho_top = GV%Rho0 + drho_dt*SST_s - rho_bot = GV%Rho0 + drho_dt*T_bot + call get_param(param_file, mdl, "S_REF", S_ref, & + "The initial salinities.", units="PSU", default=35.0, scale=US%ppt_to_S) + rho_top = (Rho_T0_S0 + dRho_dS*S_ref) + dRho_dT*SST_s + rho_bot = (Rho_T0_S0 + dRho_dS*S_ref) + dRho_dT*T_bot nz = GV%ke do k = 1,nz Rlay(k) = (rho_bot - rho_top)/(nz-1)*real(k-1) + rho_top - if (k >1) then - g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (GV%Rho0) - else + if (k==1) then g_prime(k) = GV%g_Earth + elseif (GV%Boussinesq) then + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / GV%Rho0 + else + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (0.5*(Rlay(k) + Rlay(k-1))) endif enddo diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index f3d04980f6..fcbd66e1d8 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -29,12 +29,17 @@ module BFB_surface_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 :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: SST_s !< SST at the southern edge of the linear forcing ramp [C ~> degC] real :: SST_n !< SST at the northern edge of the linear forcing ramp [C ~> degC] + real :: S_ref !< Reference salinity used throughout the domain [S ~> ppt] real :: lfrslat !< Southern latitude where the linear forcing ramp begins [degrees_N] or [km] real :: lfrnlat !< Northern latitude where the linear forcing ramp ends [degrees_N] or [km] - real :: drho_dt !< Rate of change of density with temperature [R C-1 ~> kg m-3 degC-1]. - !! Note that temperature is being used as a dummy variable here. + real :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] + real :: dRho_dT !< The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS !< The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + !! Note that temperature and salinity are being used as dummy variables here. !! All temperatures are converted into density. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -125,7 +130,7 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in [C ~> degC]) and ! salinity (in [S ~> ppt]) that are being restored toward. @@ -134,7 +139,7 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) 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)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else @@ -144,7 +149,7 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore Temp_restore = 0.0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential @@ -158,8 +163,7 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) (G%geoLatT(i,j) - CS%lfrslat) + CS%SST_s endif - density_restore = Temp_restore*CS%drho_dt + CS%Rho0 - + density_restore = (CS%Rho_T0_S0 + CS%dRho_dS*CS%S_ref) + CS%dRho_dT*Temp_restore fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo @@ -216,9 +220,17 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "SST_N", CS%SST_n, & "SST at the northern edge of the linear forcing ramp.", & units="degC", default=10.0, scale=US%degC_to_C) - call get_param(param_file, mdl, "DRHO_DT", CS%drho_dt, & - "The rate of change of density with temperature.", & + call get_param(param_file, mdl, "DRHO_DT", CS%dRho_dT, & + "The partial derivative of density with temperature.", & units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DS", CS%dRho_dS, & + "The partial derivative of density with salinity.", & + units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + call get_param(param_file, mdl, "RHO_T0_S0", CS%Rho_T0_S0, & + "The density at T=0, S=0.", units="kg m-3", default=1000.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "S_REF", CS%S_ref, & + "The reference salinity used here throughout the domain.", & + units="PSU", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& @@ -231,6 +243,11 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0)) endif end subroutine BFB_surface_forcing_init From 279ee1cb14b31dae69dc0d25e094987e6ee43aab Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 14 Aug 2023 18:38:11 -0400 Subject: [PATCH 079/146] Use GV%dZ_subroundoff Use the minimal vertical distance GV%dZ_subroundoff in 8 spots in 2 files in place of GV%H_to_Z*GV%H_subroundoff. Four internal variables were renamed for clarity of purpose in porous_widths_layer and PressureForce_Mont_Bouss. Also modified the non-Boussinesq units in a description of two integrated energy diagnostics from [H L4 T-3 ~> kg m2 s-3] to [H L4 T-3 ~> W]; these units are equivalent but the latter is more informative. Answers in all Boussinesq test cases and the existing non-Boussinesq test case in the MOM6-examples test suite are bitwise identical. --- src/core/MOM_PressureForce_Montgomery.F90 | 16 ++++++++-------- src/core/MOM_porous_barriers.F90 | 16 ++++++++-------- src/diagnostics/MOM_diagnostics.F90 | 4 ++-- 3 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index a22c73fa4d..3de713c801 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -428,7 +428,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer ! compensated density gradients [L T-2 ~> m s-2] - real :: h_neglect ! A thickness that is so small it is usually lost + real :: dz_neglect ! A vertical distance that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_EOS ! If true, density is calculated from T & S using @@ -459,7 +459,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, "can no longer be used with a compressible EOS. Use #define ANALYTIC_FV_PGF.") endif - h_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff I_Rho0 = 1.0/CS%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 @@ -582,7 +582,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, !$OMP parallel do default(shared) private(h_star,PFu_bc,PFv_bc) do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - h_star(i,j) = (e(i,j,K) - e(i,j,K+1)) + h_neglect + h_star(i,j) = (e(i,j,K) - e(i,j,K+1)) + dz_neglect enddo ; enddo do j=js,je ; do I=Isq,Ieq PFu_bc = -1.0*(rho_star(i+1,j,k) - rho_star(i,j,k)) * (G%IdxCu(I,j) * & @@ -676,7 +676,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) real :: Rho0xG ! g_Earth * Rho0 [R L2 Z-1 T-2 ~> kg s-2 m-2] logical :: use_EOS ! If true, density is calculated from T & S using ! an equation of state. - real :: z_neglect ! A thickness that is so small it is usually lost + real :: dz_neglect ! A vertical distance that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k @@ -687,14 +687,14 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Rho0xG = Rho0 * GV%g_Earth G_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) - z_neglect = GV%H_subroundoff*GV%H_to_Z + dz_neglect = GV%dZ_subroundoff if (use_EOS) then if (present(rho_star)) then !$OMP parallel do default(shared) private(Ihtot) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) pbce(i,j,1) = GFS_scale * rho_star(i,j,1) * GV%H_to_Z enddo do k=2,nz ; do i=Isq,Ieq+1 @@ -706,7 +706,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) !$OMP parallel do default(shared) private(Ihtot,press,rho_in_situ,T_int,S_int,dR_dT,dR_dS) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) press(i) = -Rho0xG*(e(i,j,1) - G%Z_ref) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & @@ -735,7 +735,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) !$OMP parallel do default(shared) private(Ihtot) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = 1.0 / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + Ihtot(i) = 1.0 / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) pbce(i,j,1) = GV%g_prime(1) * GV%H_to_Z enddo do k=2,nz ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index d73d96b242..e212581993 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -80,7 +80,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) logical, dimension(SZIB_(G),SZJB_(G)) :: do_I ! Booleans for calculation at u or v points ! updated while moving up layers real :: A_layer ! Integral of fractional open width from bottom to current layer [Z ~> m] - real :: h_min ! ! The minimum layer thickness [Z ~> m] + real :: dz_min ! The minimum layer thickness [Z ~> m] real :: dmask ! The depth below which porous barrier is not applied [Z ~> m] integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -100,7 +100,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) call calc_eta_at_uv(eta_u, eta_v, CS%eta_interp, dmask, h, tv, G, GV, US) - h_min = GV%Angstrom_H * GV%H_to_Z + dz_min = GV%Angstrom_Z ! u-points do j=js,je ; do I=Isq,Ieq ; do_I(I,j) = .False. ; enddo ; enddo @@ -125,7 +125,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq ; if (do_I(I,j)) then call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & eta_u(I,j,K), A_layer, do_I(I,j)) - if (eta_u(I,j,K) - (eta_u(I,j,K+1)+h_min) > 0.0) then + if (eta_u(I,j,K) - (eta_u(I,j,K+1)+dz_min) > 0.0) then pbv%por_face_areaU(I,j,k) = min(1.0, (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1))) else pbv%por_face_areaU(I,j,k) = 0.0 ! use calc_por_interface() might be a better choice @@ -157,7 +157,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie ; if (do_I(i,J)) then call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & eta_v(i,J,K), A_layer, do_I(i,J)) - if (eta_v(i,J,K) - (eta_v(i,J,K+1)+h_min) > 0.0) then + if (eta_v(i,J,K) - (eta_v(i,J,K+1)+dz_min) > 0.0) then pbv%por_face_areaV(i,J,k) = min(1.0, (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1))) else pbv%por_face_areaV(i,J,k) = 0.0 ! use calc_por_interface() might be a better choice @@ -286,7 +286,7 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Layer interface heights [Z ~> m]. - real :: h_neglect ! Negligible thicknesses [Z ~> m] + real :: dz_neglect ! A negligible height difference [Z ~> m] integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq is = G%isc; ie = G%iec; js = G%jsc; je = G%jec; nk = GV%ke @@ -295,7 +295,7 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) ! currently no treatment for using optional find_eta arguments if present call find_eta(h, tv, G, GV, US, eta, halo_size=1) - h_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff do K=1,nk+1 do j=js,je ; do I=Isq,Ieq ; eta_u(I,j,K) = dmask ; enddo ; enddo @@ -333,10 +333,10 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) case (ETA_INTERP_HARM) ! Harmonic mean do K=1,nk+1 do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then - eta_u(I,j,K) = 2.0 * (eta(i,j,K) * eta(i+1,j,K)) / (eta(i,j,K) + eta(i+1,j,K) + h_neglect) + eta_u(I,j,K) = 2.0 * (eta(i,j,K) * eta(i+1,j,K)) / (eta(i,j,K) + eta(i+1,j,K) + dz_neglect) endif ; enddo ; enddo do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then - eta_v(i,J,K) = 2.0 * (eta(i,j,K) * eta(i,j+1,K)) / (eta(i,j,K) + eta(i,j+1,K) + h_neglect) + eta_v(i,J,K) = 2.0 * (eta(i,j,K) * eta(i,j+1,K)) / (eta(i,j,K) + eta(i,j+1,K) + dz_neglect) endif ; enddo ; enddo enddo case default diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index c23712d8e7..253b7189e3 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -957,9 +957,9 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS real :: KE_term(SZI_(G),SZJ_(G),SZK_(GV)) ! A term in the kinetic energy budget ! [H L2 T-3 ~> m3 s-3 or W m-2] real :: KE_u(SZIB_(G),SZJ_(G)) ! The area integral of a KE term in a layer at u-points - ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + ! [H L4 T-3 ~> m5 s-3 or W] real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points - ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + ! [H L4 T-3 ~> m5 s-3 or W] real :: KE_h(SZI_(G),SZJ_(G)) ! A KE term contribution at tracer points ! [H L2 T-3 ~> m3 s-3 or W m-2] From 7d199ca052f5934b9717ca1247b40971468d61b8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 31 Jul 2023 03:20:04 -0400 Subject: [PATCH 080/146] +*Revise non-Boussinesq offline tracer diffusivity Rescale the units diapycnal diffusivity used in the offline tracer mode to work in [H Z T-1 ~> m2 s-1 or kg m-1 s-1], making it consistent with what has already been done for other diapycnal diffusivities. This change involves changes to the units of arguments to update_offline_from_files and ALE_offline_inputs and to two elements of offline_transport_CS. It also includes a new thermo_vary_type argument to offline_diabatic_ale, as well as a call to thickness_to_dz in that same routine to set the values of the newly added 3-d array of the vertical distances across layers and a change in name and units of the inverse thickness variable used to find the fluxes. All answers are bitwise identical in Boussinesq mode, but in offline tracer calculations in non-Boussinesq mode they will change to become independent of the Boussinesq reference density. --- src/ALE/MOM_ALE.F90 | 5 +++-- src/core/MOM.F90 | 2 +- src/tracer/MOM_offline_aux.F90 | 5 +++-- src/tracer/MOM_offline_main.F90 | 24 +++++++++++++++--------- 4 files changed, 22 insertions(+), 14 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index b8f60b2830..4d7445093a 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -504,13 +504,14 @@ subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_grid_type), intent(in ) :: G !< Ocean grid informations type(verticalGrid_type), intent(in ) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Zonal mass fluxes [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd !< Input diffusivities [Z2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd !< Input diffusivities + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical, intent(in ) :: debug !< If true, then turn checksums type(ocean_OBC_type), pointer :: OBC !< Open boundary structure ! Local variables diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e59c9ac60a..86040e8969 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1826,7 +1826,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! The functions related to column physics of tracers is performed separately in ALE mode if (do_vertical) then call offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS%offline_CSp, & - CS%h, eatr, ebtr) + CS%h, CS%tv, eatr, ebtr) endif ! Last thing that needs to be done is the final ALE remapping diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 7619cac2bd..bd105439c7 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -642,7 +642,8 @@ subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, s real, dimension(SZI_(G),SZJ_(G)), & intent(inout) :: mld !< Averaged mixed layer depth [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: Kd !< Diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] + intent(inout) :: Kd !< Diapycnal diffusivities at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(forcing), intent(inout) :: fluxes !< Fields with surface fluxes integer, intent(in ) :: ridx_sum !< Read index for sum, mean, and surf files integer, intent(in ) :: ridx_snap !< Read index for snapshot file @@ -696,7 +697,7 @@ subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, s ! Check if reading vertical diffusivities or entrainment fluxes call MOM_read_data( mean_file, 'Kd_interface', Kd(:,:,1:nk_input+1), G%Domain, & - timelevel=ridx_sum, position=CENTER, scale=US%m2_s_to_Z2_T) + timelevel=ridx_sum, position=CENTER, scale=GV%m2_s_to_HZ_T) ! This block makes sure that the fluxes control structure, which may not be used in the solo_driver, ! contains netMassIn and netMassOut which is necessary for the applyTracerBoundaryFluxesInOut routine diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index dcce81ef73..06af35cefd 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -22,7 +22,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_interface_heights, only : calc_derived_thermo +use MOM_interface_heights, only : calc_derived_thermo, thickness_to_dz 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 @@ -121,7 +121,8 @@ module MOM_offline_main real :: minimum_forcing_depth !< The smallest depth over which fluxes can be applied [H ~> m or kg m-2]. !! This is copied from diabatic_CS controlling how tracers follow freshwater fluxes - real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity [Z2 T-1 ~> m2 s-1] + real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: min_residual !< The minimum amount of total mass flux before exiting the main advection !! routine [H L2 ~> m3 or kg] !>@{ Diagnostic manager IDs for some fields that may be of interest when doing offline transport @@ -169,7 +170,7 @@ module MOM_offline_main !< Amount of fluid entrained from the layer below within !! one time step [H ~> m or kg m-2] ! Fields at T-points on interfaces - real, allocatable, dimension(:,:,:) :: Kd !< Vertical diffusivity [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: Kd !< Vertical diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable, dimension(:,:,:) :: h_end !< Thicknesses at the end of offline timestep [H ~> m or kg m-2] real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points [Z ~> m] @@ -651,7 +652,7 @@ end function remaining_transport_sum !> The vertical/diabatic driver for offline tracers. First the eatr/ebtr associated with the interpolated !! vertical diffusivities are calculated and then any tracer column functions are done which can include !! vertical diffuvities and source/sink terms. -subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_pre, eatr, ebtr) +subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_pre, tv, eatr, ebtr) type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type @@ -662,17 +663,20 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in ) :: tv !< A structure pointing to various thermodynamic variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: eatr !< Entrainment from layer above [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & sw, sw_vis, sw_nir !< Save old values of shortwave radiation [Q R Z T-1 ~> W m-2] - real :: I_hval ! An inverse thickness [H-1 ~> m2 kg-1] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Vertical distance across layers [Z ~> m] + real :: I_dZval ! An inverse distance between layer centers [Z-1 ~> m] integer :: i, j, k, is, ie, js, je, nz integer :: k_nonzero - real :: Kd_bot ! Near-bottom diffusivity [Z2 T-1 ~> m2 s-1] + real :: Kd_bot ! Near-bottom diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] nz = GV%ke is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -687,6 +691,8 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p call MOM_tracer_chkinv("Before offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif + call thickness_to_dz(h_pre, tv, dz, G, GV, US) + eatr(:,:,:) = 0. ebtr(:,:,:) = 0. ! Calculate eatr and ebtr if vertical diffusivity is read @@ -713,8 +719,8 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p eatr(i,j,1) = 0. enddo ; enddo do k=2,nz ; do j=js,je ; do i=is,ie - I_hval = 1.0 / (GV%H_subroundoff + 0.5*(h_pre(i,j,k-1) + h_pre(i,j,k))) - eatr(i,j,k) = GV%Z_to_H**2 * CS%dt_offline_vertical * I_hval * CS%Kd(i,j,k) + I_dZval = 1.0 / (GV%dZ_subroundoff + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + eatr(i,j,k) = CS%dt_offline_vertical * I_dZval * CS%Kd(i,j,k) ebtr(i,j,k-1) = eatr(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie @@ -1418,7 +1424,7 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & "The maximum permitted increment for the diapycnal "//& "diffusivity from TKE-based parameterizations, or a "//& - "negative value for no limit.", units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T) + "negative value for no limit.", units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "MIN_RESIDUAL_TRANSPORT", CS%min_residual, & "How much remaining transport before the main offline advection is exited. "//& "The default value corresponds to about 1 meter of difference in a grid cell", & From 72fbee0e92abd1caa858b0cd24f0e0e97673587f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 12 Aug 2023 11:23:32 -0400 Subject: [PATCH 081/146] +Obsolete 18 2018_ANSWERS runtime parameters Obsoleted 18 2018_ANSWERS parameters in 26 modules, with obsoleting message hints indicating the corresponding ANSWER_DATE parameters. The runtime parameters that have been obsoleted are DEFAULT_2018_ANSWERS, SURFACE_FORCING_2018_ANSWERS, WIND_GYRES_2018_ANSWERS, BAROTROPIC_2018_ANSWERS, EPBL_2018_ANSWERS, HOR_REGRID_2018_ANSWERS, HOR_VISC_2018_ANSWERS, IDL_HURR_2018_ANSWERS, MEKE_GEOMETRIC_2018_ANSWERS, ODA_2018_ANSWERS, OPTICS_2018_ANSWERS, REGULARIZE_LAYERS_2018_ANSWERS, REMAPPING_2018_ANSWERS, SET_DIFF_2018_ANSWERS, SET_VISC_2018_ANSWERS, SURFACE_2018_ANSWERS, TIDAL_MIXING_2018_ANSWERS and VERT_FRICTION_2018_ANSWERS. These changes will cause cases that use these older parameters to fail with a useful error message, but this change has been discussed and agreed to by the MOM6 community on July 17, 2023. All answers are bitwise identical in any cases that work. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 19 +---- .../solo_driver/MOM_surface_forcing.F90 | 21 +---- src/ALE/MOM_ALE.F90 | 21 +---- src/ALE/MOM_regridding.F90 | 19 +---- src/core/MOM.F90 | 21 +---- src/core/MOM_barotropic.F90 | 21 +---- src/core/MOM_open_boundary.F90 | 19 +---- src/diagnostics/MOM_diagnostics.F90 | 19 +---- src/diagnostics/MOM_obsolete_params.F90 | 33 ++++++++ src/framework/MOM_diag_mediator.F90 | 21 +---- .../MOM_state_initialization.F90 | 65 ++------------- .../MOM_tracer_initialization_from_Z.F90 | 40 +-------- src/ocean_data_assim/MOM_oda_driver.F90 | 22 +---- .../lateral/MOM_hor_visc.F90 | 19 +---- .../lateral/MOM_lateral_mixing_coeffs.F90 | 19 +---- .../lateral/MOM_thickness_diffuse.F90 | 20 +---- .../vertical/MOM_ALE_sponge.F90 | 82 ++----------------- .../vertical/MOM_energetic_PBL.F90 | 19 +---- .../vertical/MOM_opacity.F90 | 21 +---- .../vertical/MOM_regularize_layers.F90 | 19 +---- .../vertical/MOM_set_diffusivity.F90 | 21 +---- .../vertical/MOM_set_viscosity.F90 | 21 +---- .../vertical/MOM_tidal_mixing.F90 | 42 +--------- .../vertical/MOM_vert_friction.F90 | 22 +---- src/tracer/MOM_neutral_diffusion.F90 | 19 +---- src/user/Idealized_Hurricane.F90 | 20 +---- 26 files changed, 90 insertions(+), 595 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index 713f04dc18..164193f6d7 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -1284,10 +1284,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) ! or other equivalent files. logical :: iceberg_flux_diags ! If true, diagnostics of fluxes from icebergs are available. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: answers_2018 ! If true, use the order of arithmetic and expressions that recover - ! the answers from the end of 2018. Otherwise, use a simpler - ! expression to calculate gustiness. type(time_type) :: Time_frc type(directories) :: dirs ! A structure containing relevant directory paths and input filenames. character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. @@ -1586,22 +1582,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - call get_param(param_file, mdl, "SURFACE_FORCING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use a simpler expression to calculate gustiness.", & - default=default_2018_answers) - ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "SURFACE_FORCING_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the gustiness "//& "calculations. Values below 20190101 recover the answers from the end "//& - "of 2018, while higher values use a simpler expression to calculate gustiness. "//& - "If both SURFACE_FORCING_2018_ANSWERS and SURFACE_FORCING_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) + "of 2018, while higher values use a simpler expression to calculate gustiness.", & + default=default_answer_date) call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 8d46a80cae..5a37b18604 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1529,11 +1529,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C # include "version_variable.h" real :: flux_const_default ! The unscaled value of FLUXCONST [m day-1] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: answers_2018 ! If true, use the order of arithmetic and expressions that recover - ! the answers from the end of 2018. Otherwise, use a form of the gyre - ! wind stresses that are rotationally invariant and more likely to be - ! the same between compilers. character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=200) :: filename, gust_file ! The name of the gustiness input file. @@ -1769,24 +1764,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - call get_param(param_file, mdl, "WIND_GYRES_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use expressions for the gyre friction velocities "//& - "that are rotationally invariant and more likely to be the same between compilers.", & - default=default_2018_answers) - ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "WIND_GYRES_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions used to set gyre wind stresses. "//& "Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use a form of the gyre wind stresses that are "//& - "rotationally invariant and more likely to be the same between compilers. "//& - "If both WIND_GYRES_2018_ANSWERS and WIND_GYRES_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_answer_date) + "rotationally invariant and more likely to be the same between compilers.", & + default=default_answer_date) else CS%answer_date = 20190101 endif diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 4d7445093a..e1c8e6911e 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -170,10 +170,6 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) character(len=80) :: string, vel_string ! Temporary strings real :: filter_shallow_depth, filter_deep_depth ! Depth ranges of filtering [H ~> m or kg m-2] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: answers_2018 ! If true, use the order of arithmetic and expressions for remapping - ! that recover the answers from the end of 2018. Otherwise, use more - ! robust and accurate forms of mathematically equivalent expressions. logical :: check_reconstruction logical :: check_remapping logical :: force_bounds_in_subcell @@ -231,25 +227,12 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - 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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call initialize_remapping( CS%remapCS, string, & diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index c238c2aa61..1b006dbbd3 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -209,8 +209,6 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m logical :: tmpLogical, do_sum, main_parameters logical :: coord_is_state_dependent, ierr integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 integer :: remap_answer_date ! The vintage of the remapping expressions to use. integer :: regrid_answer_date ! The vintage of the regridding expressions to use. real :: tmpReal ! A temporary variable used in setting other variables [various] @@ -275,25 +273,12 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call set_regrid_params(CS, remap_answer_date=remap_answer_date) call get_param(param_file, mdl, "REGRIDDING_ANSWER_DATE", regrid_answer_date, & diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 86040e8969..ce001483ff 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2028,10 +2028,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & logical :: bound_salinity ! If true, salt is added to keep salinity above ! a minimum value, and the deficit is reported. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: answers_2018 ! If true, use expressions for the surface properties that recover - ! the answers from the end of 2018. Otherwise, use more appropriate - ! expressions that differ at roundoff for non-Boussinesq cases. logical :: use_conT_absS ! If true, the prognostics T & S are conservative temperature ! and absolute salinity. Care should be taken to convert them ! to potential temperature and practical salinity before @@ -2383,24 +2379,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, "MOM", "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=non_Bous) - call get_param(param_file, "MOM", "SURFACE_2018_ANSWERS", answers_2018, & - "If true, use expressions for the surface properties that recover the answers "//& - "from the end of 2018. Otherwise, use more appropriate expressions that differ "//& - "at roundoff for non-Boussinesq cases.", default=default_2018_answers, do_not_log=non_Bous) - ! Revise inconsistent default answer dates. - if (.not.non_Bous) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, "MOM", "SURFACE_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions for the surface properties. Values below "//& "20190101 recover the answers from the end of 2018, while higher values "//& - "use updated and more robust forms of the same expressions. "//& - "If both SURFACE_2018_ANSWERS and SURFACE_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=non_Bous) + "use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=non_Bous) if (non_Bous) CS%answer_date = 99991231 call get_param(param_file, "MOM", "USE_DIABATIC_TIME_BUG", CS%use_diabatic_time_bug, & diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index c814c563e3..e6f243a11c 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4358,10 +4358,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: answers_2018 ! If true, use expressions for the barotropic solver that recover - ! the answers from the end of 2018. Otherwise, use more efficient - ! or general expressions. logical :: use_BT_cont_type logical :: use_tides character(len=48) :: thickness_units, flux_units @@ -4505,24 +4501,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "BAROTROPIC_2018_ANSWERS", answers_2018, & - "If true, use expressions for the barotropic solver that recover the answers "//& - "from the end of 2018. Otherwise, use more efficient or general expressions.", & - default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions in the barotropic solver. "//& "Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values uuse more efficient or general expressions. "//& - "If both BAROTROPIC_2018_ANSWERS and BAROTROPIC_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "while higher values uuse more efficient or general expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "TIDES", use_tides, & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index ba8b8ce818..36a71e3d52 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -422,11 +422,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=1024) :: 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] - logical :: answers_2018 ! If true, use the order of arithmetic and expressions for remapping - ! that recover the answers from the end of 2018. Otherwise, use more - ! robust and accurate forms of mathematically equivalent expressions. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. logical :: check_reconstruction, check_remapping, force_bounds_in_subcell character(len=64) :: remappingScheme ! This include declares and sets the variable "version". @@ -676,23 +672,12 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - 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) - ! Revise inconsistent default answer dates for remapping. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", OBC%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date) allocate(OBC%remap_CS) call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 253b7189e3..aeb25bc351 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1572,12 +1572,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag character(len=48) :: thickness_units, flux_units logical :: use_temperature, adiabatic integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. - logical :: remap_answers_2018 CS%initialized = .true. @@ -1608,25 +1606,12 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, "SPLIT", split, default=.true., do_not_log=.true.) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 7614eb210c..b1f4444b1b 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -115,6 +115,39 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "TIDAL_SAL_SHT", hint="Use SAL_HARMONICS instead.") call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", hint="Use SAL_HARMONICS_DEGREE instead.") call obsolete_real(param_file, "RHO_E", hint="Use RHO_SOLID_EARTH instead.") + call obsolete_logical(param_file, "DEFAULT_2018_ANSWERS", hint="Instead use DEFAULT_ANSWER_DATE.") + + call obsolete_logical(param_file, "SURFACE_FORCING_2018_ANSWERS", & + hint="Instead use SURFACE_FORCING_ANSWER_DATE.") + call obsolete_logical(param_file, "WIND_GYRES_2018_ANSWERS", & + hint="Instead use WIND_GYRES_ANSWER_DATE.") + + call obsolete_logical(param_file, "BAROTROPIC_2018_ANSWERS", & + hint="Instead use BAROTROPIC_ANSWER_DATE.") + call obsolete_logical(param_file, "EPBL_2018_ANSWERS", hint="Instead use EPBL_ANSWER_DATE.") + call obsolete_logical(param_file, "HOR_REGRID_2018_ANSWERS", & + hint="Instead use HOR_REGRID_ANSWER_DATE.") + call obsolete_logical(param_file, "HOR_VISC_2018_ANSWERS", & + hint="Instead use HOR_VISC_ANSWER_DATE.") + call obsolete_logical(param_file, "IDL_HURR_2018_ANSWERS", & + hint="Instead use IDL_HURR_ANSWER_DATE.") + call obsolete_logical(param_file, "MEKE_GEOMETRIC_2018_ANSWERS", & + hint="Instead use MEKE_GEOMETRIC_ANSWER_DATE.") + call obsolete_logical(param_file, "ODA_2018_ANSWERS", hint="Instead use ODA_ANSWER_DATE.") + call obsolete_logical(param_file, "OPTICS_2018_ANSWERS", hint="Instead use OPTICS_ANSWER_DATE.") + call obsolete_logical(param_file, "REGULARIZE_LAYERS_2018_ANSWERS", & + hint="Instead use REGULARIZE_LAYERS_ANSWER_DATE.") + call obsolete_logical(param_file, "REMAPPING_2018_ANSWERS", & + hint="Instead use REMAPPING_ANSWER_DATE.") + call obsolete_logical(param_file, "SET_DIFF_2018_ANSWERS", & + hint="Instead use SET_DIFF_ANSWER_DATE.") + call obsolete_logical(param_file, "SET_VISC_2018_ANSWERS", & + hint="Instead use SET_VISC_ANSWER_DATE.") + call obsolete_logical(param_file, "SURFACE_2018_ANSWERS", hint="Instead use SURFACE_ANSWER_DATE.") + call obsolete_logical(param_file, "TIDAL_MIXING_2018_ANSWERS", & + hint="Instead use TIDAL_MIXING_ANSWER_DATE.") + call obsolete_logical(param_file, "VERT_FRICTION_2018_ANSWERS", & + hint="Instead use VERT_FRICTION_ANSWER_DATE.") ! Write the file version number to the model log. call log_version(param_file, mdl, version) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 58511c866b..61290cb579 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3144,15 +3144,11 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! Local variables integer :: ios, i, new_unit logical :: opened, new_file - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=240), allocatable :: diag_coords(:) @@ -3182,25 +3178,12 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, & 'If true, use a grid index coordinate convention for diagnostic axes. ',& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ddccf4a754..fc676781bc 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1130,10 +1130,6 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) real :: z_tolerance ! The tolerance with which to find the depth matching a specified pressure [Z ~> m]. integer :: i, j, k integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust @@ -1169,26 +1165,11 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=just_read) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=just_read.or.(.not.GV%Boussinesq)) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", & + "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) else @@ -2505,17 +2486,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just logical :: homogenize, useALEremapping, remap_full_column, remap_general, remap_old_alg integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. - logical :: hor_regrid_answers_2018 - integer :: default_hor_reg_ans_date ! The default setting for hor_regrid_answer_date integer :: hor_regrid_answer_date ! The vintage of the order of arithmetic and expressions to use ! for horizontal regridding. Values below 20190101 recover the ! answers from 2018, while higher values use expressions that have @@ -2596,55 +2570,26 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=just_read) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) call get_param(PF, mdl, "TEMP_SALT_INIT_VERTICAL_REMAP_ONLY", pre_gridded, & "If true, initial conditions are on the model horizontal grid. " //& "Extrapolation over missing ocean values is done using an ICE-9 "//& "procedure with vertical ALE remapping .", & default=.false., do_not_log=just_read) if (useALEremapping) then - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=just_read.or.(.not.GV%Boussinesq)) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 - endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", & - default=default_remap_ans_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif - call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizontal regridding that recovers "//& - "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", & - default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) - ! Revise inconsistent default answer dates for horizontal regridding. - default_hor_reg_ans_date = default_answer_date - if (GV%Boussinesq) then - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 - endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& - "Dates after 20230101 use reproducing sums for global averages. "//& - "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", & - default=default_hor_reg_ans_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) if (.not.useALEremapping) then diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index decd197b2b..808430df2c 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -87,17 +87,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ integer :: nPoints ! The number of valid input data points in a column integer :: id_clock_routine, id_clock_ALE integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. - logical :: hor_regrid_answers_2018 - integer :: default_hor_reg_ans_date ! The default setting for hor_regrid_answer_date integer :: hor_regrid_answer_date ! The vintage of the order of arithmetic and expressions to use ! for horizontal regridding. Values below 20190101 recover the ! answers from 2018, while higher values use expressions that have @@ -125,46 +118,21 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) if (useALE) then - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 - endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif - call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizonal regridding that recovers "//& - "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for horizontal regridding. - default_hor_reg_ans_date = default_answer_date - if (GV%Boussinesq) then - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 - endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& - "Dates after 20230101 use reproducing sums for global averages. "//& - "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=.not.GV%Boussinesq) + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) if (PRESENT(homogenize)) homog=homogenize diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index fc67b20e87..875051b6c7 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -182,11 +182,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) character(len=80) :: basin_var character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file - logical :: 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. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) @@ -253,25 +249,11 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(PF, mdl, "ODA_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from original version of the ODA driver. Otherwise, use updated and "//& - "more robust forms of the same expressions.", & - default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(PF, mdl, "ODA_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions used by the ODA driver "//& "Values below 20190101 recover the answers from the end of 2018, while higher "//& - "values use updated and more robust forms of the same expressions. "//& - "If both ODA_2018_ANSWERS and ODA_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) inputdir = slasher(inputdir) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index f9a35c1e3d..2d1c38abf9 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1758,11 +1758,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. logical :: use_MEKE ! If true, the MEKE parameterization is in use. - logical :: 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. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags character(len=200) :: inputdir, filename ! Input file names and paths character(len=80) :: Kh_var ! Input variable names real :: deg2rad ! Converts degrees to radians [radians degree-1] @@ -1793,24 +1789,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "HOR_VISC_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for horizontal viscosity. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "HOR_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the horizontal "//& "viscosity calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& - "same expressions. If both HOR_VISC_2018_ANSWERS and HOR_VISC_ANSWER_DATE are "//& - "specified, the latter takes precedence.", & + "same expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index d3ee675269..1bf416b00a 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1110,8 +1110,6 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! default value is roughly (pi / (the age of the universe)). logical :: Gill_equatorial_Ld, use_FGNV_streamfn, use_MEKE, in_use integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust @@ -1505,25 +1503,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 1de4c9ba6b..248a90d76a 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2090,10 +2090,6 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: MEKE_GEOM_answers_2018 ! If true, use expressions in the MEKE_GEOMETRIC calculation - ! that recover the answers from the original implementation. - ! Otherwise, use expressions that satisfy rotational symmetry. integer :: i, j CS%initialized = .true. @@ -2246,24 +2242,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "MEKE_GEOMETRIC_2018_ANSWERS", MEKE_GEOM_answers_2018, & - "If true, use expressions in the MEKE_GEOMETRIC calculation that recover the "//& - "answers from the original implementation. Otherwise, use expressions that "//& - "satisfy rotational symmetry.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for MEKE_geometric. - if (GV%Boussinesq) then - if (MEKE_GEOM_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.MEKE_GEOM_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "MEKE_GEOMETRIC_ANSWER_DATE", CS%MEKE_GEOM_answer_date, & "The vintage of the expressions in the MEKE_GEOMETRIC calculation. "//& "Values below 20190101 recover the answers from the original implementation, "//& - "while higher values use expressions that satisfy rotational symmetry. "//& - "If both MEKE_GEOMETRIC_2018_ANSWERS and MEKE_GEOMETRIC_ANSWER_DATE are "//& - "specified, the latter takes precedence.", & + "while higher values use expressions that satisfy rotational symmetry.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%MEKE_GEOM_answer_date = max(CS%MEKE_GEOM_answer_date, 20230701) endif diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 1faeed00ba..508362c4cc 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -180,15 +180,6 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date - logical :: hor_regrid_answers_2018 ! If true, use the order of arithmetic for horizontal regridding - ! that recovers the answers from the end of 2018. Otherwise, use - ! rotationally symmetric forms of the same expressions. - integer :: default_hor_reg_ans_date ! The default setting for hor_regrid_answer_date integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -226,45 +217,20 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - endif - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) - call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizontal regridding that recovers "//& - "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for horizontal regridding. - default_hor_reg_ans_date = default_answer_date - if (GV%Boussinesq) then - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 - endif call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& - "Dates after 20230101 use reproducing sums for global averages. "//& - "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=.not.GV%Boussinesq) + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%hor_regrid_answer_date = max(CS%hor_regrid_answer_date, 20230701) CS%time_varying_sponges = .false. @@ -477,15 +443,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date - logical :: hor_regrid_answers_2018 ! If true, use the order of arithmetic for horizontal regridding - ! that recovers the answers from the end of 2018. Otherwise, use - ! rotationally symmetric forms of the same expressions. - integer :: default_hor_reg_ans_date ! The default setting for hor_regrid_answer_date integer :: i, j, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -522,41 +479,18 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date) - call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizontal regridding that recovers "//& - "the answers from the end of 2018 and retain a bug in the 3-dimensional mask "//& - "returned in certain cases. Otherwise, use rotationally symmetric "//& - "forms of the same expressions and initialize the mask properly.", & - default=default_2018_answers) - ! Revise inconsistent default answer dates for horizontal regridding. - default_hor_reg_ans_date = default_answer_date - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date) call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& - "Dates after 20230101 use reproducing sums for global averages. "//& - "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date) + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date) call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & "When defined, the incoming sponge data are "//& "assumed to be on the model grid " , & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 06c3915d84..17da7aceb3 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1962,10 +1962,6 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) integer :: isd, ied, jsd, jed integer :: mstar_mode, LT_enhance, wT_mode integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: 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. logical :: use_temperature, use_omega logical :: use_la_windsea isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2006,24 +2002,11 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "EPBL_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for horizontal viscosity. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "EPBL_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the energetic "//& "PBL calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& - "same expressions. If both EPBL_2018_ANSWERS and EPBL_ANSWER_DATE are "//& - "specified, the latter takes precedence.", & + "same expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index ac93e54785..c48308a912 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -962,11 +962,7 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) real :: PenSW_absorb_minthick ! A thickness that is used to absorb the remaining shortwave heat ! flux when that flux drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2] real :: PenSW_minthick_dflt ! The default for PenSW_absorb_minthick [m] - logical :: 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. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags integer :: isd, ied, jsd, jed, nz, n isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke @@ -1067,25 +1063,10 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "OPTICS_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 expressions for "//& - "handling the absorption of small remaining shortwave fluxes.", & - default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for optics. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "OPTICS_ANSWER_DATE", optics%answer_date, & "The vintage of the order of arithmetic and expressions in the optics calculations. "//& "Values below 20190101 recover the answers from the end of 2018, while "//& - "higher values use updated and more robust forms of the same expressions. "//& - "If both OPTICS_2018_ANSWERS and OPTICS_ANSWER_DATE are "//& - "specified, the latter takes precedence.", & + "higher values use updated and more robust forms of the same expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) optics%answer_date = max(optics%answer_date, 20230701) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index d4034d699c..b00238f60c 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -719,10 +719,6 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) # include "version_variable.h" character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags - logical :: 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. logical :: just_read integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -760,24 +756,11 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=just_read) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) - call get_param(param_file, mdl, "REGULARIZE_LAYERS_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, do_not_log=just_read.or.(.not.GV%Boussinesq)) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REGULARIZE_LAYERS_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the regularize "//& "layers calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& - "same expressions. If both REGULARIZE_LAYERS_2018_ANSWERS and "//& - "REGULARIZE_LAYERS_ANSWER_DATE are specified, the latter takes precedence.", & + "same expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) endif diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index c792f5200e..c404e94459 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2067,10 +2067,6 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ real :: decay_length ! The maximum decay scale for the BBL diffusion [H ~> m or kg m-2] logical :: ML_use_omega integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: 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. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_set_diffusivity" ! This module's name. @@ -2124,24 +2120,11 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "SET_DIFF_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "SET_DIFF_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the set diffusivity "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values use updated and more robust forms of the same expressions. "//& - "If both SET_DIFF_2018_ANSWERS and SET_DIFF_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "while higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) ! CS%use_tidal_mixing is set to True if an internal tidal dissipation scheme is to be used. diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 9a99bc6b26..a6c463a7b9 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2233,10 +2233,6 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS integer :: i, j, k, is, ie, js, je integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: 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. logical :: adiabatic, use_omega, MLE_use_PBL_MLD logical :: use_KPP logical :: use_regridding ! If true, use the ALE algorithm rather than layered @@ -2266,24 +2262,11 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "SET_VISC_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "SET_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the set viscosity "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values use updated and more robust forms of the same expressions. "//& - "If both SET_VISC_2018_ANSWERS and SET_VISC_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "while higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 95ffe19afb..6e53679549 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -230,15 +230,6 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di logical :: int_tide_dissipation logical :: read_tideamp integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date - integer :: default_tide_ans_date ! The default setting for tides_answer_date - logical :: tide_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. character(len=20) :: tmpstr, int_tide_profile_str character(len=20) :: CVMix_tidal_scheme_str, tidal_energy_type character(len=200) :: filename, h2_file, Niku_TKE_input_file ! Input file names @@ -295,44 +286,19 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "TIDAL_MIXING_2018_ANSWERS", tide_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for the tidal mixing. - default_tide_ans_date = default_answer_date - if (GV%Boussinesq) then - if (tide_answers_2018 .and. (default_tide_ans_date >= 20190101)) default_tide_ans_date = 20181231 - if (.not.tide_answers_2018 .and. (default_tide_ans_date < 20190101)) default_tide_ans_date = 20190101 - endif call get_param(param_file, mdl, "TIDAL_MIXING_ANSWER_DATE", CS%tidal_answer_date, & "The vintage of the order of arithmetic and expressions in the tidal mixing "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values use updated and more robust forms of the same expressions. "//& - "If both TIDAL_MIXING_2018_ANSWERS and TIDAL_MIXING_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_tide_ans_date, do_not_log=.not.GV%Boussinesq) + "while higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%tidal_answer_date = max(CS%tidal_answer_date, 20230701) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) if (CS%int_tide_dissipation) then diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index b0b47bf2b1..212512dabf 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2247,11 +2247,6 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & real :: Kv_BBL ! A viscosity in the bottom boundary layer with a simple scheme [H Z T-1 ~> m2 s-1 or Pa s] real :: Kv_back_z ! A background kinematic viscosity [Z2 T-1 ~> m2 s-1] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use expressions that do not - !! use an arbitrary and hard-coded maximum viscous coupling coefficient - !! between layers. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz character(len=200) :: kappa_gl90_file, inputdir, kdgl90_varname ! This include declares and sets the variable "version". @@ -2282,28 +2277,13 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "VERT_FRICTION_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use expressions that do not use an arbitrary "//& - "hard-coded maximum viscous coupling coefficient between layers.", & - default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "VERT_FRICTION_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the viscous "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use expressions that do not use an arbitrary hard-coded "//& "maximum viscous coupling coefficient between layers. Values below 20230601 "//& "recover a form of the viscosity within the mixed layer that breaks up the "//& - "magnitude of the wind stress in some non-Boussinesq cases. "//& - "If both VERT_FRICTION_2018_ANSWERS and VERT_FRICTION_ANSWER_DATE are "//& - "specified, the latter takes precedence.", & + "magnitude of the wind stress in some non-Boussinesq cases.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 21201db590..720e0012b0 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -129,10 +129,6 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, ! Local variables character(len=80) :: string ! Temporary strings integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the answers for remapping from the end of 2018. - ! Otherwise, use more robust forms of the same expressions. logical :: boundary_extrap if (associated(CS)) then @@ -191,23 +187,12 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_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, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & answer_date=CS%remap_answer_date ) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 5dd8084fbd..0c9d5cd330 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -104,10 +104,6 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] real :: C ! A temporary variable [nondim] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: answers_2018 ! If true, use expressions driving the idealized hurricane test - ! case that recover the answers from the end of 2018. Otherwise use - ! expressions that are rescalable and respect rotational symmetry. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -174,23 +170,11 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - call get_param(param_file, mdl, "IDL_HURR_2018_ANSWERS", answers_2018, & - "If true, use expressions driving the idealized hurricane test case that recover "//& - "the answers from the end of 2018. Otherwise use expressions that are rescalable "//& - "and respect rotational symmetry.", default=default_2018_answers) - - ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "IDL_HURR_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions in the idealized hurricane test case. "//& "Values below 20190101 recover the answers from the end of 2018, while higher "//& - "values use expressions that are rescalable and respect rotational symmetry. "//& - "If both IDL_HURR_2018_ANSWERS and IDL_HURR_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_answer_date) + "values use expressions that are rescalable and respect rotational symmetry.", & + default=default_answer_date) ! The following parameters are model run-time parameters which are used ! and logged elsewhere and so should not be logged here. The default From 9f7f86d304d664e5a7ed63271cfb8ef32644d876 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 29 Aug 2023 10:37:01 -0400 Subject: [PATCH 082/146] Autoconf: Update deps m4 macros This patch updates the macros used in the `ac/deps` directory. It includes a bugfix in the library testing, and also bundles the macro for testing Fortran links to C libraries. Both of these macros were already in `ac/m4` but unused by `ac/deps`. No problems were observed in any recent FMS builds, although in principle they could have been affected by these errors. The issues were only detected when the macros were used in an unrelated project (LM3 land model). These issues are due to code duplication in `ac/m4` and `ac/deps/m4`. This separation was intended to draw a clear logical separation between MOM6 and its FMS dependency, and only provide what is required by each respective build. But perhaps there are some flaws in this thinking, and may warrant further discussion. --- ac/deps/m4/ax_fc_check_c_lib.m4 | 45 +++++++++++++++++++++++++++++++++ ac/deps/m4/ax_fc_check_lib.m4 | 13 +++++----- 2 files changed, 52 insertions(+), 6 deletions(-) create mode 100644 ac/deps/m4/ax_fc_check_c_lib.m4 diff --git a/ac/deps/m4/ax_fc_check_c_lib.m4 b/ac/deps/m4/ax_fc_check_c_lib.m4 new file mode 100644 index 0000000000..af5765282a --- /dev/null +++ b/ac/deps/m4/ax_fc_check_c_lib.m4 @@ -0,0 +1,45 @@ +dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C library can be referenced by a Fortran compiler. +dnl +dnl Results are cached in `ax_fc_cv_c_lib_LIBRARY_FUNCTION`. +dnl +dnl NOTE: Might be possible to rewrite this to use `AX_FC_CHECK_BIND_C`. +dnl +AC_DEFUN([AX_FC_CHECK_C_LIB], [ + AS_VAR_PUSHDEF([ax_fc_C_Lib], [ax_fc_cv_c_lib_$1_$2]) + m4_ifval([$5], + [ax_fc_c_lib_msg_LDFLAGS=" with $5"], + [ax_fc_c_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [for $2 in -l$1$ax_fc_c_lib_msg_LDFLAGS], [ax_fc_cv_c_lib_$1_$2], [ + ax_fc_check_c_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$6 $LDFLAGS" + ax_fc_check_c_lib_save_LIBS=$LIBS + LIBS="-l$1 $7 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$2") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_C_Lib], [yes])], + [AS_VAR_SET([ax_fc_C_Lib], [no])] + ) + LDFLAGS=$ax_fc_check_c_lib_save_LDFLAGS + LIBS=$ax_fc_check_c_lib_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_C_Lib], [yes], + [m4_default([$3], [LIBS="-l$1 $LIBS"])], + [$4] + ) + AS_VAR_POPDEF([ax_fc_C_Lib]) +]) diff --git a/ac/deps/m4/ax_fc_check_lib.m4 b/ac/deps/m4/ax_fc_check_lib.m4 index c0accab6cd..a7f848cd60 100644 --- a/ac/deps/m4/ax_fc_check_lib.m4 +++ b/ac/deps/m4/ax_fc_check_lib.m4 @@ -18,7 +18,7 @@ dnl library with different -L flags, or perhaps other ld configurations. dnl dnl Results are cached in the ax_fc_cv_lib_LIBRARY_FUNCTION variable. dnl -AC_DEFUN([AX_FC_CHECK_LIB],[dnl +AC_DEFUN([AX_FC_CHECK_LIB],[ AS_VAR_PUSHDEF([ax_fc_Lib], [ax_fc_cv_lib_$1_$2]) m4_ifval([$6], [ax_fc_lib_msg_LDFLAGS=" with $6"], @@ -29,14 +29,15 @@ AC_DEFUN([AX_FC_CHECK_LIB],[dnl LDFLAGS="$6 $LDFLAGS" ax_fc_check_lib_save_LIBS=$LIBS LIBS="-l$1 $7 $LIBS" - AS_IF([test -n $3], + AS_IF([test -n "$3"], [ax_fc_use_mod="use $3"], [ax_fc_use_mod=""]) - AC_LINK_IFELSE([ - AC_LANG_PROGRAM([], [dnl + AC_LINK_IFELSE([dnl +dnl Begin 7-column code block +AC_LANG_PROGRAM([], [dnl $ax_fc_use_mod - call $2]dnl - ) + call $2])dnl +dnl End code block ], [AS_VAR_SET([ax_fc_Lib], [yes])], [AS_VAR_SET([ax_fc_Lib], [no])] From 1577ae1c516ba72d1b0f287666527b6cfcfbbcda Mon Sep 17 00:00:00 2001 From: alex-huth Date: Wed, 23 Aug 2023 15:59:33 -0400 Subject: [PATCH 083/146] Ice-shelf bugfixes for restarts and halo updates This commit fixes a combination of bugs related to halo update errors, improperly-defined iteration bounds, and an unexpected change in ice-shelf bed_elev after a restart. These issues caused crashes during the ice-shelf velocity (SSA) solution, and ice shelf dynamics restarts were not bitwise identical. The issues were resolved with the following changes: -Added bed_elev to the ice shelf restart file (previously, bed_elev was instead calculated incorrectly after a restart). Also fixed the subsequent bed_elev pass_var call, where the halo update was failing due to an error in how an optional argument (CENTER) was passed. -Added additional pass_var/pass_vector calls upon ice shelf restarts to guarantee that all halos are properly filled. -Disabled the additional ice shelf flow solve (ice_shelf_solve_outer) after a restart, which was unnecessary and prevented bitwise identical restarts. -Fixed incorrect bounds for iterations within ice_shelf_solve_inner and for the basis functions in calc_shelf_visc This commit also sets the mol_wt argument to optional in the dummy function aof_set_coupler_flux (from ice_solo_driver/atmost_ocean_fluxes.F90), as that is how it is called from the FMS coupler. This is required for compilation in ice-shelf-only mode. --- .../ice_solo_driver/atmos_ocean_fluxes.F90 | 3 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 63 +++++++++++-------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 15 ++--- 3 files changed, 48 insertions(+), 33 deletions(-) diff --git a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 index 5494954398..4a4ddf6da3 100644 --- a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 @@ -13,7 +13,7 @@ module atmos_ocean_fluxes_mod !> This subroutine duplicates an interface used by the FMS coupler, but only !! returns a value of -1. None of the arguments are used for anything. function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, & - param, flag, ice_restart_file, ocean_restart_file, & + param, flag, mol_wt, ice_restart_file, ocean_restart_file, & units, caller, verbosity) result (coupler_index) character(len=*), intent(in) :: name !< An unused argument @@ -22,6 +22,7 @@ function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, integer, optional, intent(in) :: atm_tr_index !< An unused argument real, dimension(:), optional, intent(in) :: param !< An unused argument logical, dimension(:), optional, intent(in) :: flag !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 9b584ae0f9..cefe251edd 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -265,23 +265,23 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", T_shelf_missing, & "An ice shelf temperature to use where there is no ice shelf.",& units="degC", default=-10.0, scale=US%degC_to_C, do_not_log=.true.) - allocate( CS%u_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing ) ! [C ~> degC] - allocate( CS%ice_visc(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25 ) ! [Pa-3 s-1] - allocate( CS%basal_traction(isd:ied,jsd:jed), source=0.0 ) ! [R L2 T-2 ~> Pa] - allocate( CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10 ) ! [Pa (m-1 s)^n_sliding] - allocate( CS%OD_av(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%ground_frac(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%taudy_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%bed_elev(isd:ied,jsd:jed) ) ; CS%bed_elev(:,:) = G%bathyT(:,:) + G%Z_ref - allocate( CS%u_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%v_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB), source=-2.0 ) - allocate( CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB), source=-2.0 ) - allocate( CS%h_bdry_val(isd:ied,jsd:jed), source=0.0 ) + allocate(CS%u_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing) ! [C ~> degC] + allocate(CS%ice_visc(isd:ied,jsd:jed), source=0.0) + allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] + allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L2 T-2 ~> Pa] + allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] + allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) + allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) + allocate(CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%taudy_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%bed_elev(isd:ied,jsd:jed), source=0.0) + allocate(CS%u_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%v_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB), source=-2.0) + allocate(CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB), source=-2.0) + allocate(CS%h_bdry_val(isd:ied,jsd:jed), source=0.0) ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & "ice sheet/shelf u-velocity", & @@ -310,6 +310,8 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) "ice-stiffness parameter", "Pa-3 s-1") call register_restart_field(CS%h_bdry_val, "h_bdry_val", .false., restart_CS, & "ice thickness at the boundary", "m", conversion=US%Z_to_m) + call register_restart_field(CS%bed_elev, "bed elevation", .true., restart_CS, & + "bed elevation", "m", conversion=US%Z_to_m) endif end subroutine register_ice_shelf_dyn_restarts @@ -509,7 +511,15 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%ice_visc,G%domain) call pass_var(CS%basal_traction, G%domain) call pass_var(CS%AGlen_visc, G%domain) + call pass_var(CS%bed_elev, G%domain) + call pass_var(CS%C_basal_friction, G%domain) + call pass_var(CS%h_bdry_val, G%domain) + call pass_var(CS%thickness_bdry_val, G%domain) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif if (active_shelf_dynamics) then @@ -561,7 +571,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf, CS%ground_frac, & G, US, param_file) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var(CS%bed_elev, G%domain,CENTER) + call pass_var(CS%ground_frac, G%domain) + call pass_var(CS%bed_elev, G%domain) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif ! Register diagnostics. @@ -590,8 +601,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) endif call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") - call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + if (new_sim) then + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + endif end subroutine initialize_ice_shelf_dyn @@ -955,7 +967,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - call pass_vector(Au,Av,G%domain,TO_ALL,BGRID_NE) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) if (CS%nonlin_solve_err_mode == 1) then err_init = 0 ; err_tempu = 0 ; err_tempv = 0 @@ -1012,6 +1024,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + err_max = 0 if (CS%nonlin_solve_err_mode == 1) then @@ -1225,7 +1239,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! the computational domain - this is their state in the initial iteration - is = isc - cg_halo ; ie = iecq + cg_halo + is = iscq - cg_halo ; ie = iecq + cg_halo js = jscq - cg_halo ; je = jecq + cg_halo Au(:,:) = 0 ; Av(:,:) = 0 @@ -2595,10 +2609,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset - allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + allocate(Phi(1:8,1:4,isc:iec,jsc:jec), source=0.0) -! do j=jsc,jec ; do i=isc,iec - do j=jscq,jecq ; do i=iscq,iecq + do j=jsc,jec ; do i=isc,iec call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) enddo ; enddo diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index e49fb03aaf..dce6e53982 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -429,31 +429,32 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& filename = trim(inputdir)//trim(vel_file) call log_param(PF, mdl, "INPUTDIR/THICKNESS_FILE", filename) call get_param(PF, mdl, "ICE_U_VEL_VARNAME", ushelf_varname, & - "The name of the thickness variable in ICE_VELOCITY_FILE.", & + "The name of the u velocity variable in ICE_VELOCITY_FILE.", & default="u_shelf") call get_param(PF, mdl, "ICE_V_VEL_VARNAME", vshelf_varname, & - "The name of the thickness variable in ICE_VELOCITY_FILE.", & + "The name of the v velocity variable in ICE_VELOCITY_FILE.", & default="v_shelf") call get_param(PF, mdl, "ICE_VISC_VARNAME", ice_visc_varname, & - "The name of the thickness variable in ICE_VELOCITY_FILE.", & + "The name of the ice viscosity variable in ICE_VELOCITY_FILE.", & default="viscosity") + call get_param(PF, mdl, "ICE_FLOAT_FRAC_VARNAME", floatfr_varname, & + "The name of the ice float fraction (grounding fraction) variable in ICE_VELOCITY_FILE.", & + default="float_frac") call get_param(PF, mdl, "BED_TOPO_FILE", bed_topo_file, & "The file from which the bed elevation is read.", & default="ice_shelf_vel.nc") call get_param(PF, mdl, "BED_TOPO_VARNAME", bed_varname, & - "The name of the thickness variable in ICE_INPUT_FILE.", & + "The name of the bed elevation variable in ICE_INPUT_FILE.", & default="depth") if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) - floatfr_varname = "float_frac" - call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) call MOM_read_data(filename, trim(vshelf_varname), v_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) call MOM_read_data(filename, trim(floatfr_varname), float_cond, G%Domain, scale=1.) filename = trim(inputdir)//trim(bed_topo_file) - call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.0) + call MOM_read_data(filename, trim(bed_varname), bed_elev, G%Domain, scale=US%m_to_Z) end subroutine initialize_ice_flow_from_file From 1d35fa1c2f984b94041029f6857e6dfaa410198f Mon Sep 17 00:00:00 2001 From: raphael dussin Date: Fri, 8 Sep 2023 14:02:48 -0400 Subject: [PATCH 084/146] implement restart for internal tides (#463) * implement restart for internal tides * add a call to register restart diabatic in MOM * register restart diabatic call register restart internal tides * internal tides restart uses the extra_axes optional argument * support for extra_axes added to MOM_restart/MOM_io * implement 4d restart/ parallel_restart not working * add proper documentation for extra axes * fix read restart for 4d array * passes global_file optional arg to allow reading in parallel restart files * write one restart variable per vertical mode vertical modes >= 6 do not propagate hence there is no need for dynamic array size on this dimension --------- Co-authored-by: Raphael Dussin --- src/core/MOM.F90 | 11 +- src/framework/MOM_io.F90 | 71 +++-- src/framework/MOM_restart.F90 | 80 +++++- .../lateral/MOM_internal_tides.F90 | 272 ++++++++++++++---- .../vertical/MOM_diabatic_driver.F90 | 38 ++- 5 files changed, 371 insertions(+), 101 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ce001483ff..d112de07b7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -62,6 +62,7 @@ module MOM use MOM_coord_initialization, only : MOM_initialize_coord, write_vertgrid_file use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end +use MOM_diabatic_driver, only : register_diabatic_restarts use MOM_stochastics, only : stochastics_init, update_stochastics, stochastic_CS use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics @@ -94,6 +95,7 @@ module MOM use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end use MOM_interface_filter, only : interface_filter_CS +use MOM_internal_tides, only : int_tide_CS use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS use MOM_MEKE, only : MEKE_alloc_register_restart, step_forward_MEKE @@ -409,6 +411,8 @@ module MOM type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() !< Pointer to the oda incremental update control structure type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() + !< Pointer to the internal tides control structure + type(int_tide_CS), pointer :: int_tide_CSp => NULL() !< Pointer to the ALE-mode sponge control structure type(ALE_CS), pointer :: ALE_CSp => NULL() !< Pointer to the Arbitrary Lagrangian Eulerian (ALE) vertical coordinate control structure @@ -1964,6 +1968,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & type(ice_shelf_CS), optional, pointer :: ice_shelf_CSp !< A pointer to an ice shelf control structure type(Wave_parameters_CS), & optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS + ! local variables type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the metric grid use for the run type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid @@ -2774,6 +2779,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call stoch_EOS_register_restarts(HI, param_file, CS%stoch_eos_CS, restart_CSp) endif + if (.not. CS%adiabatic) then + call register_diabatic_restarts(G, US, param_file, CS%int_tide_CSp, restart_CSp) + endif + call callTree_waypoint("restart registration complete (initialize_MOM)") call restart_registry_lock(restart_CSp) @@ -3139,7 +3148,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & else call diabatic_driver_init(Time, G, GV, US, param_file, CS%use_ALE_algorithm, diag, & CS%ADp, CS%CDp, CS%diabatic_CSp, CS%tracer_flow_CSp, & - CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp) + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%int_tide_CSp) endif if (associated(CS%sponge_CSp)) & diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 220a7d6bcf..27d244b226 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -148,6 +148,20 @@ module MOM_io module procedure read_attribute_int32, read_attribute_int64 end interface read_attribute +!> Type that stores information that can be used to create a non-decomposed axis. +type :: axis_info + character(len=32) :: name = "" !< The name of this axis for use in files + character(len=256) :: longname = "" !< A longer name describing this axis + character(len=48) :: units = "" !< The units of the axis labels + character(len=8) :: cartesian = "N" !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 + !! if they increase downward. The default, 0, is ignored. + integer :: ax_size = 0 !< The number of elements in this axis + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis [arbitrary] +end type axis_info + !> Type for describing a 3-d variable for output type, public :: vardesc character(len=64) :: name !< Variable name in a NetCDF file @@ -165,22 +179,9 @@ module MOM_io character(len=32) :: dim_names(5) !< The names in the file of the axes for this variable integer :: position = -1 !< An integer encoding the horizontal position, it may !! CENTER, CORNER, EAST_FACE, NORTH_FACE, or 0. + type(axis_info) :: extra_axes(5) !< dimensions other than space-time end type vardesc -!> Type that stores information that can be used to create a non-decomposed axis. -type :: axis_info ; private - character(len=32) :: name = "" !< The name of this axis for use in files - character(len=256) :: longname = "" !< A longer name describing this axis - character(len=48) :: units = "" !< The units of the axis labels - character(len=8) :: cartesian = "N" !< A variable indicating which direction - !! this axis corresponds with. Valid values - !! include 'X', 'Y', 'Z', 'T', and 'N' for none. - integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 - !! if they increase downward. The default, 0, is ignored. - integer :: ax_size = 0 !< The number of elements in this axis - real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis [arbitrary] -end type axis_info - !> Type that stores for a global file attribute type :: attribute_info ; private character(len=:), allocatable :: name !< The name of this attribute @@ -271,7 +272,8 @@ subroutine create_MOM_file(IO_handle, filename, vars, novars, fields, & !! required if the new file uses any !! vertical grid axes. integer(kind=int64), optional, intent(in) :: checksums(:,:) !< checksums of vars - type(axis_info), optional, intent(in) :: extra_axes(:) !< Types with information about + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< Types with information about !! some axes that might be used in this file type(attribute_info), optional, intent(in) :: global_atts(:) !< Global attributes to !! write to this file @@ -1751,7 +1753,8 @@ end subroutine verify_variable_units !! have default values that are empty strings or are appropriate for a 3-d !! tracer field at the tracer cell centers. function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_name, & - cmor_units, cmor_longname, conversion, caller, position, dim_names, fixed) result(vd) + cmor_units, cmor_longname, conversion, caller, position, dim_names, & + extra_axes, fixed) result(vd) character(len=*), intent(in) :: name !< variable name character(len=*), optional, intent(in) :: units !< variable units character(len=*), optional, intent(in) :: longname !< variable long name @@ -1772,6 +1775,8 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_na !! NORTH_FACE, and 0 for no horizontal dimensions. character(len=*), dimension(:), & optional, intent(in) :: dim_names !< The names of the dimensions of this variable + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time logical, optional, intent(in) :: fixed !< If true, this does not evolve with time type(vardesc) :: vd !< vardesc type that is created @@ -1795,7 +1800,8 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_na call modify_vardesc(vd, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid, position=position, dim_names=dim_names, & cmor_field_name=cmor_field_name, cmor_units=cmor_units, & - cmor_longname=cmor_longname, conversion=conversion, caller=cllr) + cmor_longname=cmor_longname, conversion=conversion, caller=cllr, & + extra_axes=extra_axes) end function var_desc @@ -1803,7 +1809,8 @@ end function var_desc !> This routine modifies the named elements of a vardesc type. !! All arguments are optional, except the vardesc type to be modified. subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, cmor_longname, conversion, caller, position, dim_names) + cmor_field_name, cmor_units, cmor_longname, conversion, caller, position, dim_names, & + extra_axes) type(vardesc), intent(inout) :: vd !< vardesc type that is modified character(len=*), optional, intent(in) :: name !< name of variable character(len=*), optional, intent(in) :: units !< units of variable @@ -1825,6 +1832,8 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & !! NORTH_FACE, and 0 for no horizontal dimensions. character(len=*), dimension(:), & optional, intent(in) :: dim_names !< The names of the dimensions of this variable + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time character(len=120) :: cllr integer :: n @@ -1877,6 +1886,12 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & endif ; enddo endif + if (present(extra_axes)) then + do n=1,size(extra_axes) ; if (len_trim(extra_axes(n)%name) > 0) then + vd%extra_axes(n) = extra_axes(n) + endif ; enddo + endif + end subroutine modify_vardesc integer function position_from_horgrid(hor_grid) @@ -2020,7 +2035,7 @@ end function cmor_long_std !> This routine queries vardesc subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & cmor_field_name, cmor_units, cmor_longname, conversion, caller, & - position, dim_names) + extra_axes, position, dim_names) type(vardesc), intent(in) :: vd !< vardesc type that is queried character(len=*), optional, intent(out) :: name !< name of variable character(len=*), optional, intent(out) :: units !< units of variable @@ -2035,6 +2050,8 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & !! convert from intensive to extensive !! [various] or [a A-1 ~> 1] character(len=*), optional, intent(in) :: caller !< calling routine? + type(axis_info), dimension(5), & + optional, intent(out) :: extra_axes !< dimensions other than space-time integer, optional, intent(out) :: position !< A coded integer indicating the horizontal position !! of this variable if it has such dimensions. !! Valid values include CORNER, CENTER, EAST_FACE @@ -2043,7 +2060,8 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & optional, intent(out) :: dim_names !< The names of the dimensions of this variable integer :: n - character(len=120) :: cllr + integer, parameter :: nmax_extraaxes = 5 + character(len=120) :: cllr, varname cllr = "mod_vardesc" if (present(caller)) cllr = trim(caller) @@ -2076,6 +2094,19 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & enddo endif + if (present(extra_axes)) then + ! save_restart expects 5 extra axes (can be empty) + do n=1, nmax_extraaxes + if (vd%extra_axes(n)%ax_size>=1) then + extra_axes(n) = vd%extra_axes(n) + else + ! return an empty axis + write(varname,"('dummy',i1.1)") n + call set_axis_info(extra_axes(n), name=trim(varname), ax_size=1) + endif + enddo + endif + end subroutine query_vardesc diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 75051c32ba..252f14bfac 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -14,6 +14,7 @@ module MOM_restart use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix use MOM_io, only : MULTIPLE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_io, only : axis_info, get_axis_info use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type, time_type_to_real, real_to_time use MOM_time_manager, only : days_in_month, get_date, set_date @@ -26,6 +27,7 @@ module MOM_restart public restart_registry_lock, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run public register_restart_field_as_obsolete, register_restart_pair +public lock_check ! 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 @@ -445,7 +447,7 @@ end subroutine register_restart_pair_ptr4d !> Register a 4-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, conversion, & - hor_grid, z_grid, t_grid) + hor_grid, z_grid, t_grid, extra_axes) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written !! in arbitrary rescaled units [A ~> a] @@ -460,8 +462,26 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time type(vardesc) :: vd + character(len=32), dimension(:), allocatable :: dim_names + integer :: n, n_extradims + + ! first 2 dimensions in dim_names are reserved for i,j + ! so extra_dimensions are shifted to index 3. + ! this is designed not to break the behavior in SIS2 + ! (see register_restart_field_4d in SIS_restart.F90) + if (present(extra_axes)) then + n_extradims = size(extra_axes) + allocate(dim_names(n_extradims+2)) + dim_names(1) = "" + dim_names(2) = "" + do n=3,n_extradims+2 + dim_names(n) = extra_axes(n-2)%name + enddo + endif if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_4d: Module must be initialized before "//& @@ -469,8 +489,13 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units call lock_check(CS, name=name) - vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid) + if (present(extra_axes)) then + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, dim_names=dim_names, extra_axes=extra_axes) + else + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + endif call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS, conversion) @@ -478,7 +503,7 @@ end subroutine register_restart_field_4d !> Register a 3-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, conversion, & - hor_grid, z_grid, t_grid) + hor_grid, z_grid, t_grid, extra_axes) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written !! in arbitrary rescaled units [A ~> a] @@ -493,8 +518,26 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time type(vardesc) :: vd + character(len=32), dimension(:), allocatable :: dim_names + integer :: n, n_extradims + + ! first 2 dimensions in dim_names are reserved for i,j + ! so extra_dimensions are shifted to index 3. + ! this is designed not to break the behavior in SIS2 + ! (see register_restart_field_4d in SIS_restart.F90) + if (present(extra_axes)) then + n_extradims = size(extra_axes) + allocate(dim_names(n_extradims+2)) + dim_names(1) = "" + dim_names(2) = "" + do n=3,n_extradims+2 + dim_names(n) = extra_axes(n-2)%name + enddo + endif if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_3d: Module must be initialized before "//& @@ -502,8 +545,13 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units call lock_check(CS, name=name) - vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid) + if (present(extra_axes)) then + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, dim_names=dim_names, extra_axes=extra_axes) + else + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + endif call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS, conversion) @@ -1309,7 +1357,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer :: start_var, next_var ! The starting variables of the ! current and next files. type(MOM_infra_file) :: IO_handle ! The I/O handle of the open fileset - integer :: m, nz + integer :: m, nz, na integer :: num_files ! The number of restart files that will be used. integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. @@ -1320,9 +1368,13 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer(kind=8) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos integer :: turns + integer, parameter :: nmax_extradims = 5 + type(axis_info), dimension(:), allocatable :: extra_axes turns = CS%turns + allocate (extra_axes(nmax_extradims)) + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "save_restart: Module must be initialized before it is used.") @@ -1361,8 +1413,14 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ do m=start_var,CS%novars call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid, caller="save_restart") + z_grid=z_grid, t_grid=t_grid, caller="save_restart", & + extra_axes=extra_axes) + var_sz = get_variable_byte_size(hor_grid, z_grid, t_grid, G, nz) + ! factor in size of extra axes, or multiply by 1 + do na=1,nmax_extradims + var_sz = var_sz*extra_axes(na)%ax_size + enddo if ((m==start_var) .OR. (size_in_file < max_file_size-var_sz)) then size_in_file = size_in_file + var_sz @@ -1445,10 +1503,10 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ if (CS%parallel_restartfiles) then call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & - fields, MULTIPLE, G=G, GV=GV, checksums=check_val) + fields, MULTIPLE, G=G, GV=GV, checksums=check_val, extra_axes=extra_axes) else call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & - fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val) + fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val, extra_axes=extra_axes) endif do m=start_var,next_var-1 @@ -1650,7 +1708,7 @@ subroutine restore_state(filename, directory, day, G, CS) elseif (associated(CS%var_ptr4d(m)%p)) then ! Read a 4d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & - G%Domain, timelevel=1, position=pos, scale=scale) + G%Domain, timelevel=1, position=pos, scale=scale, global_file=unit_is_global(n)) else ! This array is not domain-decomposed. This variant may be under-tested. call MOM_error(FATAL, & "MOM_restart does not support 4-d arrays without domain decomposition.") diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 788e922ff2..83910e6690 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -16,8 +16,10 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, MOM_read_data, file_exists +use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info +use MOM_io, only : set_axis_info, get_axis_info use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart +use MOM_restart, only : lock_check, restart_registry_lock use MOM_spatial_means, only : global_area_integral use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type @@ -29,12 +31,13 @@ module MOM_internal_tides #include -public propagate_int_tide !, register_int_tide_restarts +public propagate_int_tide, register_int_tide_restarts public internal_tides_init, internal_tides_end public get_lowmode_loss !> This control structure has parameters for the MOM_internal_tides module type, public :: int_tide_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. logical :: do_int_tides !< If true, use the internal tide code. integer :: nFreq = 0 !< The number of internal tide frequency bands integer :: nMode = 1 !< The number of internal tide vertical modes @@ -137,8 +140,17 @@ module MOM_internal_tides real, allocatable :: En(:,:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,frequency,mode) !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] - real, allocatable :: En_restart(:,:,:) - !< The internal wave energy density as a function of (i,j,angle); temporary for restart + real, allocatable :: En_restart_mode1(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 1 + real, allocatable :: En_restart_mode2(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 2 + real, allocatable :: En_restart_mode3(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 3 + real, allocatable :: En_restart_mode4(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 4 + real, allocatable :: En_restart_mode5(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 5 + real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. type(wave_speed_CS) :: wave_speed !< Wave speed control structure @@ -266,6 +278,35 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, cn(:,:,:) = 0. + ! Rebuild energy density array from multiple restarts + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + if (CS%nMode >= 2) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 3) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 4) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 5) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + ! Set properties related to the internal tides, such as the wave speeds, storing some ! of them in the control structure for this module. if (CS%uniform_test_cg > 0.0) then @@ -323,7 +364,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -344,7 +385,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call correct_halo_rotation(CS%En, test, G, CS%nAngle) ! Propagate the waves. - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq CS%TKE_residual_loss(:,:,:,fr,m) = 0. @@ -353,7 +394,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset @@ -369,13 +410,13 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ; enddo ! Apply the other half of the refraction. - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & G, US, CS%NAngle, CS%use_PPMang) enddo ; enddo ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -394,7 +435,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, .or. (CS%id_tot_En > 0)) then tot_En(:,:) = 0.0 tot_En_mode(:,:,:,:) = 0.0 - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq do j=jsd,jed ; do i=isd,ied ; do a=1,CS%nAngle tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) tot_En_mode(i,j,fr,m) = tot_En_mode(i,j,fr,m) + CS%En(i,j,a,fr,m) @@ -412,7 +453,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -453,7 +494,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -471,7 +512,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! still need to allow a portion of the extracted energy to go to higher modes. ! First, find velocity profiles if (CS%apply_wave_drag .or. CS%apply_Froude_drag) then - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq ! compute near-bottom and max horizontal baroclinic velocity values at each point do j=jsd,jed ; do i=isd,ied @@ -519,7 +560,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, CS%TKE_itidal_loss, dt, full_halos=.false.) endif ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -535,7 +576,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Extract the energy for mixing due to wave breaking----------------------------- if (CS%apply_Froude_drag) then ! Pick out maximum baroclinic velocity values; calculate Fr=max(u)/cg - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq freq2 = CS%frequency(fr)**2 do j=js,je ; do i=is,ie id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -586,7 +627,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo endif ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset @@ -618,7 +659,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Check for energy conservation on computational domain.************************* - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') enddo ; enddo @@ -638,7 +679,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, TKE_itidal_input, CS%diag) ! Output 2-D energy density (summed over angles) for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then tot_En(:,:) = 0.0 do a=1,CS%nAngle ; do j=js,je ; do i=is,ie tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) @@ -646,8 +687,37 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call post_data(CS%id_En_mode(fr,m), tot_En, CS%diag) endif ; enddo ; enddo + ! split energy array into multiple restarts + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) + enddo ; enddo ; enddo ; enddo + + if (CS%nMode >= 2) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 3) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 4) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 5) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) + enddo ; enddo ; enddo ; enddo + endif + ! Output 3-D (i,j,a) energy density for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_En_ang_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_ang_mode(fr,m) > 0) then call post_data(CS%id_En_ang_mode(fr,m), CS%En(:,:,:,fr,m) , CS%diag) endif ; enddo ; enddo @@ -658,7 +728,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, tot_Froude_loss(:,:) = 0.0 tot_residual_loss(:,:) = 0.0 tot_allprocesses_loss(:,:) = 0.0 - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie tot_leak_loss(i,j) = tot_leak_loss(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) tot_quad_loss(i,j) = tot_quad_loss(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) tot_itidal_loss(i,j) = tot_itidal_loss(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) @@ -696,7 +766,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, endif ! Output 2-D energy loss (summed over angles) for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq if (CS%id_itidal_loss_mode(fr,m) > 0 .or. CS%id_allprocesses_loss_mode(fr,m) > 0) then itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) allprocesses_loss_mode(:,:) = 0.0 ! all processes summed together @@ -712,37 +782,37 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, endif ; enddo ; enddo ! Output 3-D (i,j,a) energy loss for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_itidal_loss_ang_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_itidal_loss_ang_mode(fr,m) > 0) then call post_data(CS%id_itidal_loss_ang_mode(fr,m), CS%TKE_itidal_loss(:,:,:,fr,m) , CS%diag) endif ; enddo ; enddo ! Output 2-D period-averaged horizontal near-bottom mode velocity for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_Ub_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_Ub_mode(fr,m) > 0) then call post_data(CS%id_Ub_mode(fr,m), Ub(:,:,fr,m), CS%diag) endif ; enddo ; enddo - do m=1,CS%NMode ; if (CS%id_Ustruct_mode(m) > 0) then + do m=1,CS%nMode ; if (CS%id_Ustruct_mode(m) > 0) then call post_data(CS%id_Ustruct_mode(m), CS%u_struct(:,:,:,m), CS%diag) endif ; enddo - do m=1,CS%NMode ; if (CS%id_Wstruct_mode(m) > 0) then + do m=1,CS%nMode ; if (CS%id_Wstruct_mode(m) > 0) then call post_data(CS%id_Wstruct_mode(m), CS%w_struct(:,:,:,m), CS%diag) endif ; enddo - do m=1,CS%NMode ; if (CS%id_int_w2_mode(m) > 0) then + do m=1,CS%nMode ; if (CS%id_int_w2_mode(m) > 0) then call post_data(CS%id_int_w2_mode(m), CS%int_w2(:,:,m), CS%diag) endif ; enddo - do m=1,CS%NMode ; if (CS%id_int_U2_mode(m) > 0) then + do m=1,CS%nMode ; if (CS%id_int_U2_mode(m) > 0) then call post_data(CS%id_int_U2_mode(m), CS%int_U2(:,:,m), CS%diag) endif ; enddo - do m=1,CS%NMode ; if (CS%id_int_N2w2_mode(m) > 0) then + do m=1,CS%nMode ; if (CS%id_int_N2w2_mode(m) > 0) then call post_data(CS%id_int_N2w2_mode(m), CS%int_N2w2(:,:,m), CS%diag) endif ; enddo ! Output 2-D horizontal phase velocity for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_cp_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_cp_mode(fr,m) > 0) then call post_data(CS%id_cp_mode(fr,m), CS%cp(:,:,fr,m), CS%diag) endif ; enddo ; enddo @@ -2276,43 +2346,120 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) enddo ; enddo end subroutine PPM_limit_pos -! subroutine register_int_tide_restarts(G, param_file, CS, restart_CS) -! type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure -! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! type(int_tide_CS), intent(in) :: CS !< Internal tide control structure -! type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure +subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) + 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(int_tide_CS), pointer :: CS !< Internal tide control structure + type(MOM_restart_CS), pointer :: restart_CS !< MOM restart control structure + + ! This subroutine is used to allocate and register any fields in this module + ! that should be written to or read from the restart file. + logical :: use_int_tides + integer :: num_freq, num_angle , num_mode, period_1 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, i, j, a, fr + character(64) :: var_name, cfr + + type(axis_info) :: axes_inttides(2) + real, dimension(:), allocatable :: angles, freqs + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (associated(CS)) then + call MOM_error(WARNING, "register_int_tide_restarts called "//& + "with an associated control structure.") + return + endif + + allocate(CS) + + ! write extra axes + call get_param(param_file, "MOM", "INTERNAL_TIDE_ANGLES", num_angle, default=24) + call get_param(param_file, "MOM", "INTERNAL_TIDE_FREQS", num_freq, default=1) + call get_param(param_file, "MOM", "INTERNAL_TIDE_MODES", num_mode, default=1) + + allocate (angles(num_angle)) + allocate (freqs(num_freq)) + + do a=1,num_angle ; angles(a)= a ; enddo + do fr=1,num_freq ; freqs(fr)= fr ; enddo + + call set_axis_info(axes_inttides(1), "angle", "", "angle direction", num_angle, angles, "N", 1) + call set_axis_info(axes_inttides(2), "freq", "", "wave frequency", num_freq, freqs, "N", 1) + + ! full energy array + allocate(CS%En(isd:ied, jsd:jed, num_angle, num_freq, num_mode), source=0.0) + + ! restart strategy: support for 5d restart is not yet available so we split into + ! 4d restarts. Vertical modes >= 6 are dissipated locally and do not propagate + ! so we only allow for 5 vertical modes and each has its own variable + + ! allocate restart arrays + allocate(CS%En_restart_mode1(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 2) allocate(CS%En_restart_mode2(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 3) allocate(CS%En_restart_mode3(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 4) allocate(CS%En_restart_mode4(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 5) allocate(CS%En_restart_mode5(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + + ! register all 4d restarts and copy into full Energy array when restarting from previous state + call register_restart_field(CS%En_restart_mode1(:,:,:,:), "IW_energy_mode1", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 1", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + if (num_mode >= 2) then + call register_restart_field(CS%En_restart_mode2(:,:,:,:), "IW_energy_mode2", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 2", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif + + if (num_mode >= 3) then + call register_restart_field(CS%En_restart_mode3(:,:,:,:), "IW_energy_mode3", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 3", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) -! ! This subroutine is not currently in use!! + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif -! ! This subroutine is used to allocate and register any fields in this module -! ! that should be written to or read from the restart file. -! logical :: use_int_tides -! integer :: num_freq, num_angle , num_mode, period_1 -! integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, a -! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed -! IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + if (num_mode >= 4) then + call register_restart_field(CS%En_restart_mode4(:,:,:,:), "IW_energy_mode4", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 4", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) -! if (associated(CS)) then -! call MOM_error(WARNING, "register_int_tide_restarts called "//& -! "with an associated control structure.") -! return -! endif + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + enddo ; enddo ; enddo ; enddo -! use_int_tides = .false. -! call read_param(param_file, "INTERNAL_TIDES", use_int_tides) -! if (.not.use_int_tides) return + endif -! allocate(CS) + if (num_mode >= 5) then + call register_restart_field(CS%En_restart_mode5(:,:,:,:), "IW_energy_mode5", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 5", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) -! num_angle = 24 -! call read_param(param_file, "INTERNAL_TIDE_ANGLES", num_angle) -! allocate(CS%En_restart(isd:ied, jsd:jed, num_angle), source=0.0) + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + enddo ; enddo ; enddo ; enddo -! call register_restart_field(CS%En_restart, "En_restart", .false., restart_CS, & -! longname="The internal wave energy density as a function of (i,j,angle,frequency,mode)", & -! units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1') + endif -! end subroutine register_int_tide_restarts +end subroutine register_int_tide_restarts !> This subroutine initializes the internal tides module. subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) @@ -2324,7 +2471,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !! parameters. type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. - type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure + type(int_tide_CS), pointer :: CS !< Internal tide control structure ! Local variables real :: Angle_size ! size of wedges [rad] @@ -2358,6 +2505,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed nz = GV%ke + CS%initialized = .true. + use_int_tides = .false. call read_param(param_file, "INTERNAL_TIDES", use_int_tides) CS%do_int_tides = use_int_tides @@ -2376,9 +2525,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (.not.((num_freq > 0) .and. (num_angle > 0) .and. (num_mode > 0))) return CS%nFreq = num_freq ; CS%nAngle = num_angle ; CS%nMode = num_mode - ! Allocate energy density array - allocate(CS%En(isd:ied, jsd:jed, num_angle, num_freq, num_mode), source=0.0) - ! Allocate phase speed array allocate(CS%cp(isd:ied, jsd:jed, num_freq, num_mode), source=0.0) @@ -2430,7 +2576,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "Inconsistent number of frequencies.") if (CS%NAngle /= num_angle) call MOM_error(FATAL, "Internal_tides_init: "//& "Inconsistent number of angles.") - if (CS%NMode /= num_mode) call MOM_error(FATAL, "Internal_tides_init: "//& + if (CS%nMode /= num_mode) call MOM_error(FATAL, "Internal_tides_init: "//& "Inconsistent number of modes.") if (4*(num_angle/4) /= num_angle) call MOM_error(FATAL, & "Internal_tides_init: INTERNAL_TIDE_ANGLES must be a multiple of 4.") diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index b2b8527819..1ccd6a7fb2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -45,7 +45,7 @@ module MOM_diabatic_driver use MOM_int_tide_input, only : set_int_tide_input, int_tide_input_init use MOM_int_tide_input, only : int_tide_input_end, int_tide_input_CS, int_tide_input_type use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz -use MOM_internal_tides, only : propagate_int_tide +use MOM_internal_tides, only : propagate_int_tide, register_int_tide_restarts use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS use MOM_kappa_shear, only : kappa_shear_is_used use MOM_CVMix_KPP, only : KPP_CS, KPP_init, KPP_compute_BLD, KPP_calculate @@ -56,6 +56,7 @@ module MOM_diabatic_driver use MOM_opacity, only : absorbRemainingSW, optics_type, optics_nbands use MOM_open_boundary, only : ocean_OBC_type use MOM_regularize_layers, only : regularize_layers, regularize_layers_init, regularize_layers_CS +use MOM_restart, only : MOM_restart_CS use MOM_set_diffusivity, only : set_diffusivity, set_BBL_TKE use MOM_set_diffusivity, only : set_diffusivity_init, set_diffusivity_end use MOM_set_diffusivity, only : set_diffusivity_CS @@ -81,6 +82,7 @@ module MOM_diabatic_driver public extract_diabatic_member public adiabatic public adiabatic_driver_init +public register_diabatic_restarts ! 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 @@ -226,12 +228,13 @@ module MOM_diabatic_driver type(KPP_CS), pointer :: KPP_CSp => NULL() !< Control structure for a child module type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() !< Control structure for a child module type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() !< Control structure for a child module + type(int_tide_CS), pointer :: int_tide_CSp => NULL() !< Control structure for a child module + type(bulkmixedlayer_CS) :: bulkmixedlayer !< Bulk mixed layer control structure type(CVMix_conv_CS) :: CVMix_conv !< CVMix convection control structure type(energetic_PBL_CS) :: ePBL !< Energetic PBL control structure type(entrain_diffusive_CS) :: entrain_diffusive !< Diffusive entrainment control structure type(geothermal_CS) :: geothermal !< Geothermal control structure - type(int_tide_CS) :: int_tide !< Internal tide control structure type(opacity_CS) :: opacity !< Opacity control structure type(regularize_layers_CS) :: regularize_layers !< Regularize layer control structure @@ -386,7 +389,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & CS%int_tide_input_CSp) call propagate_int_tide(h, tv, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & - CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, G, GV, US, CS%int_tide) + CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, G, GV, US, CS%int_tide_CSp) if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides @@ -2980,7 +2983,7 @@ end subroutine adiabatic_driver_init !> This routine initializes the diabatic driver module. subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, diag, & ADp, CDp, CS, tracer_flow_CSp, sponge_CSp, & - ALE_sponge_CSp, oda_incupd_CSp) + ALE_sponge_CSp, oda_incupd_CSp, int_tide_CSp) type(time_type), target :: Time !< model time type(ocean_grid_type), intent(inout) :: G !< model grid structure type(verticalGrid_type), intent(in) :: GV !< model vertical grid structure @@ -2998,6 +3001,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< pointer to the ALE sponge module control structure type(oda_incupd_CS), pointer :: oda_incupd_CSp !< pointer to the ocean data assimilation incremental !! update module control structure + type(int_tide_CS), pointer :: int_tide_CSp !< pointer to the internal tide structure ! Local variables real :: Kd ! A diffusivity used in the default for other tracer diffusivities [Z2 T-1 ~> m2 s-1] @@ -3032,6 +3036,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (associated(sponge_CSp)) CS%sponge_CSp => sponge_CSp if (associated(ALE_sponge_CSp)) CS%ALE_sponge_CSp => ALE_sponge_CSp if (associated(oda_incupd_CSp)) CS%oda_incupd_CSp => oda_incupd_CSp + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp CS%useALEalgorithm = useALEalgorithm CS%use_bulkmixedlayer = (GV%nkml > 0) @@ -3497,12 +3502,14 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (CS%use_int_tides) then call int_tide_input_init(Time, G, GV, US, param_file, diag, CS%int_tide_input_CSp, & CS%int_tide_input) - call internal_tides_init(Time, G, GV, US, param_file, diag, CS%int_tide) + call internal_tides_init(Time, G, GV, US, param_file, diag, int_tide_CSp) endif + !if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + physical_OBL_scheme = (CS%use_bulkmixedlayer .or. CS%use_KPP .or. CS%use_energetic_PBL) ! initialize module for setting diffusivities - call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, CS%int_tide, & + call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, CS%int_tide_CSp, & halo_TS=CS%halo_TS_diff, double_diffuse=CS%double_diffuse, & physical_OBL_scheme=physical_OBL_scheme) @@ -3558,6 +3565,25 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di end subroutine diabatic_driver_init +!> Routine to register restarts, pass-through to children modules +subroutine register_diabatic_restarts(G, US, param_file, int_tide_CSp, restart_CSp) + 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(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure + type(MOM_restart_CS), pointer :: restart_CSp !< MOM restart control structure + + logical :: use_int_tides + + use_int_tides=.false. + + call read_param(param_file, "INTERNAL_TIDES", use_int_tides) + + if (use_int_tides) then + call register_int_tide_restarts(G, US, param_file, int_tide_CSp, restart_CSp) + endif + +end subroutine register_diabatic_restarts !> Routine to close the diabatic driver module subroutine diabatic_driver_end(CS) From 1bb8852186e7cc6972077ff2557310ca46cf4c82 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 9 Aug 2023 13:31:39 -0400 Subject: [PATCH 085/146] *+Non-Boussinesq MEKE and add MEKE_TOTAL_DEPTH_RHO This commit revises MOM_MEKE to work in with total depths in thickness units to avoid any dependence on the Boussinesq reference density in non-Boussinesq mode, while retaining the previous answers in Boussinesq mode. It also adds the new runtime parameter MEKE_TOTAL_DEPTH_RHO to specify the density that is used to convert the bathymetric depth into a nominal ocean mass in non-Boussinesq mode when MEKE is enabled and MEKE_FIXED_TOTAL_DEPTH is true. There is a new element in the MEKE_CS type, and the scaled units of two other elements (cdrag and MEKE_min_depth_tot) are altered. The units of a total of 5 arguments to the private routines MEKE_equilibrium, MEKE_equilibrium_restoring, MEKE_lengthScales and MEKE_lengthScales_0d where changed consistently with the broader changes here. There is also a new vertical_grid type argument to MEKE_equilibrium_restoring. The units of 6 internal variables are changed, 2 new internal variable were added and 5 internal variables were eliminated. There are 4 places where multiplication by a GV%H_to_Z thickness rescaling factor was eliminated, while 4 instances that use GV%Rho0 directly were effectively replaced by the use of GV%H_to_RZ. All Boussinesq answers are bitwise identical, but answers will change in non-Boussinesq mode and there is a new runtime parameter the MOM_parameter_doc files for some non-Boussinesq simulations. --- src/parameterizations/lateral/MOM_MEKE.F90 | 125 +++++++++++---------- 1 file changed, 67 insertions(+), 58 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 3059ca1637..a44eec7727 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -75,15 +75,15 @@ module MOM_MEKE !! which is calculated at each time step. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather !! than the streamfunction for the MEKE GM source term. - real :: MEKE_min_depth_tot !< The minimum total depth over which to distribute MEKE energy - !! sources from GM energy conversion [Z ~> m]. When the total - !! depth is less than this, the sources are scaled away. + real :: MEKE_min_depth_tot !< The minimum total thickness over which to distribute MEKE energy + !! sources from GM energy conversion [H ~> m or kg m-2]. When the total + !! thickness is less than this, the sources are scaled away. logical :: Rd_as_max_scale !< If true the length scale can not exceed the !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. logical :: use_min_lscale !< Use simple minimum for mixing length scale. real :: lscale_maxval !< The ceiling on the MEKE mixing length scale when use_min_lscale is true [L ~> m]. - real :: cdrag !< The bottom drag coefficient for MEKE [nondim]. + real :: cdrag !< The bottom drag coefficient for MEKE, times rescaling factors [H L-1 ~> nondim or kg m-3] real :: MEKE_BGsrc !< Background energy source for MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). real :: MEKE_dtScale !< Scale factor to accelerate time-stepping [nondim] real :: MEKE_KhCoeff !< Scaling factor to convert MEKE into Kh [nondim] @@ -115,6 +115,9 @@ module MOM_MEKE logical :: fixed_total_depth !< If true, use the nominal bathymetric depth as the estimate of !! the time-varying ocean depth. Otherwise base the depth on the total !! ocean mass per unit area. + real :: rho_fixed_total_depth !< A density used to translate the nominal bathymetric depth into an + !! estimate of the total ocean mass per unit area when MEKE_FIXED_TOTAL_DEPTH + !! is true [R ~> kg m-3] logical :: kh_flux_enabled !< If true, lateral diffusive MEKE flux is enabled. logical :: initialize !< If True, invokes a steady state solver to calculate MEKE. logical :: debug !< If true, write out checksums of data for debugging @@ -186,10 +189,10 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h data_eke, & ! EKE from file [L2 T-2 ~> m2 s-2] mass, & ! The total mass of the water column [R Z ~> kg m-2]. I_mass, & ! The inverse of mass [R-1 Z-1 ~> m2 kg-1]. - depth_tot, & ! The depth of the water column [Z ~> m]. + depth_tot, & ! The depth of the water column [H ~> m or kg m-2]. src, & ! The sum of all MEKE sources [L2 T-3 ~> W kg-1] (= m2 s-3). MEKE_decay, & ! A diagnostic of the MEKE decay timescale [T-1 ~> s-1]. - drag_rate_visc, & ! Near-bottom velocity contribution to bottom drag [L T-1 ~> m s-1] + drag_rate_visc, & ! Near-bottom velocity contribution to bottom drag [H T-1 ~> m s-1 or kg m-2 s-1] drag_rate, & ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. del2MEKE, & ! Laplacian of MEKE, used for bi-harmonic diffusion [T-2 ~> s-2]. del4MEKE, & ! Time-integrated MEKE tendency arising from the biharmonic of MEKE [L2 T-2 ~> m2 s-2]. @@ -205,23 +208,21 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! In one place, MEKE_uflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_u, & ! The zonal diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHu, & ! Depth integrated accumulated zonal mass flux [R Z L2 ~> kg]. - drag_vel_u ! A (vertical) viscosity associated with bottom drag at u-points [Z T-1 ~> m s-1]. + drag_vel_u ! A piston velocity associated with bottom drag at u-points [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G),SZJB_(G)) :: & MEKE_vflux, & ! The meridional advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m2 s-3]. ! In one place, MEKE_vflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_v, & ! The meridional diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHv, & ! Depth integrated accumulated meridional mass flux [R Z L2 ~> kg]. - drag_vel_v ! A (vertical) viscosity associated with bottom drag at v-points [Z T-1 ~> m s-1]. + drag_vel_v ! A piston velocity associated with bottom drag at v-points [H T-1 ~> m s-1 or kg m-2 s-1] real :: Kh_here ! The local horizontal viscosity [L2 T-1 ~> m2 s-1] real :: Inv_Kh_max ! The inverse of the local horizontal viscosity [T L-2 ~> s m-2] real :: K4_here ! The local horizontal biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Inv_K4_max ! The inverse of the local horizontal biharmonic viscosity [T L-4 ~> s m-4] - real :: cdrag2 ! The square of the drag coefficient [nondim] + real :: cdrag2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] real :: advFac ! The product of the advection scaling factor and 1/dt [T-1 ~> s-1] real :: mass_neglect ! A negligible mass [R Z ~> kg m-2]. real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. - real :: Rho0 ! A density used to convert mass to distance [R ~> kg m-3] - real :: I_Rho0 ! The inverse of the density used to convert mass to distance [R-1 ~> m3 kg-1] real :: sdt ! dt to use locally [T ~> s] (could be scaled to accelerate) real :: sdt_damp ! dt for damping [T ~> s] (sdt could be split). logical :: use_drag_rate ! Flag to indicate drag_rate is finite @@ -266,8 +267,6 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping - Rho0 = GV%Rho0 - I_Rho0 = 1.0 / GV%Rho0 mass_neglect = GV%H_to_RZ * GV%H_subroundoff cdrag2 = CS%cdrag**2 @@ -311,18 +310,18 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h do j=js,je ; do I=is-1,ie drag_vel_u(I,j) = 0.0 if ((G%mask2dCu(I,j) > 0.0) .and. (visc%bbl_thick_u(I,j) > 0.0)) & - drag_vel_u(I,j) = GV%H_to_Z*visc%Kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) + drag_vel_u(I,j) = visc%Kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie drag_vel_v(i,J) = 0.0 if ((G%mask2dCv(i,J) > 0.0) .and. (visc%bbl_thick_v(i,J) > 0.0)) & - drag_vel_v(i,J) = GV%H_to_Z*visc%Kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) + drag_vel_v(i,J) = visc%Kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate_visc(i,j) = (0.25*G%IareaT(i,j) * US%Z_to_L * & + drag_rate_visc(i,j) = (0.25*G%IareaT(i,j) * & ((G%areaCu(I-1,j)*drag_vel_u(I-1,j) + & G%areaCu(I,j)*drag_vel_u(I,j)) + & (G%areaCv(i,J-1)*drag_vel_v(i,J-1) + & @@ -348,14 +347,21 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo if (CS%fixed_total_depth) then - !$OMP parallel do default(shared) - do j=js-1,je+1 ; do i=is-1,ie+1 - depth_tot(i,j) = G%bathyT(i,j) + G%Z_ref - enddo ; enddo + if (GV%Boussinesq) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + depth_tot(i,j) = (G%bathyT(i,j) + G%Z_ref) * GV%Z_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + depth_tot(i,j) = (G%bathyT(i,j) + G%Z_ref) * CS%rho_fixed_total_depth * GV%RZ_to_H + enddo ; enddo + endif else !$OMP parallel do default(shared) do j=js-1,je+1 ; do i=is-1,ie+1 - depth_tot(i,j) = mass(i,j) * I_Rho0 + depth_tot(i,j) = mass(i,j) * GV%RZ_to_H enddo ; enddo endif @@ -369,9 +375,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%debug) then if (CS%visc_drag) & call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, & - scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + scale=GV%H_to_mks*US%s_to_T, scalar_pair=.true.) call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%RZ_to_kg_m2) - call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=US%L_T_to_m_s) + call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=GV%H_to_mks*US%s_to_T) call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) call hchksum(barotrFac2, 'MEKE barotrFac2', G%HI) call hchksum(LmixScale, 'MEKE LmixScale', G%HI,scale=US%L_to_m) @@ -402,7 +408,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_GMcoeff*MEKE%GM_src(i,j) / & - (GV%Rho0 * MAX(CS%MEKE_min_depth_tot, depth_tot(i,j))) + (GV%H_to_RZ * MAX(CS%MEKE_min_depth_tot, depth_tot(i,j))) enddo ; enddo else !$OMP parallel do default(shared) @@ -413,7 +419,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif if (CS%MEKE_equilibrium_restoring) then - call MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & + call MEKE_equilibrium_restoring(CS, G, GV, US, SN_u, SN_v, depth_tot, & equilibrium_value) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_restoring_rate*(MEKE%MEKE(i,j) - equilibrium_value(i,j)) @@ -434,7 +440,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Calculate a viscous drag rate (includes BBL contributions from mean flow and eddies) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate(i,j) = (US%L_to_Z*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo else @@ -607,7 +613,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (use_drag_rate) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate(i,j) = (US%L_to_Z*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo endif @@ -753,20 +759,19 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: drag_rate_visc !< Mean flow velocity contribution - !! to the MEKE drag rate [L T-1 ~> m s-1] + !! to the MEKE drag rate [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: I_mass !< Inverse of column mass [R-1 Z-1 ~> m2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. ! Local variables real :: beta ! Combined topographic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] real :: SN ! The local Eady growth rate [T-1 ~> s-1] real :: bottomFac2, barotrFac2 ! Vertical structure factors [nondim] real :: LmixScale, LRhines, LEady ! Various mixing length scales [L ~> m] - real :: I_H ! The inverse of the total column mass, converted to an inverse horizontal length [L-1 ~> m-1] real :: KhCoeff ! A copy of MEKE_KhCoeff from the control structure [nondim] real :: Kh ! A lateral diffusivity [L2 T-1 ~> m2 s-1] real :: Ubg2 ! Background (tidal?) velocity squared [L2 T-2 ~> m2 s-2] - real :: cd2 ! The square of the drag coefficient [nondim] + real :: cd2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] real :: drag_rate ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. real :: src ! The sum of MEKE sources [L2 T-3 ~> W kg-1] real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. @@ -774,7 +779,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real :: resid, ResMin, ResMax ! Residuals [L2 T-3 ~> W kg-1] real :: FatH ! Coriolis parameter at h points; to compute topographic beta [T-1 ~> s-1] real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] - real :: dZ_neglect ! A negligible change in height [Z ~> m] + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2] integer :: i, j, is, ie, js, je, n1, n2 real :: tolerance ! Width of EKE bracket [L2 T-2 ~> m2 s-2]. logical :: useSecant, debugIteration @@ -786,7 +791,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m Ubg2 = CS%MEKE_Uscale**2 cd2 = CS%cdrag**2 tolerance = 1.0e-12*US%m_s_to_L_T**2 - dZ_neglect = GV%H_to_Z*GV%H_subroundoff + h_neglect = GV%H_subroundoff !$OMP do do j=js,je ; do i=is,ie @@ -795,7 +800,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) if (CS%MEKE_equilibrium_alt) then - MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * US%Z_to_L*depth_tot(i,j))**2 / cd2 + MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * depth_tot(i,j))**2 / cd2 else FatH = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))) ! Coriolis parameter at h points @@ -807,21 +812,19 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m !### Consider different combinations of these estimates of topographic beta. beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i+1,j)-depth_tot(i,j)) * G%IdxCu(I,j) & - / max(depth_tot(i+1,j), depth_tot(i,j), dZ_neglect) & + / max(depth_tot(i+1,j), depth_tot(i,j), h_neglect) & + (depth_tot(i,j)-depth_tot(i-1,j)) * G%IdxCu(I-1,j) & - / max(depth_tot(i,j), depth_tot(i-1,j), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i-1,j), h_neglect) ) beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i,j+1)-depth_tot(i,j)) * G%IdyCv(i,J) & - / max(depth_tot(i,j+1), depth_tot(i,j), dZ_neglect) + & + / max(depth_tot(i,j+1), depth_tot(i,j), h_neglect) + & (depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) & - / max(depth_tot(i,j), depth_tot(i,j-1), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) ) endif beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & (G%dF_dy(i,j) + beta_topo_y)**2 ) - I_H = US%L_to_Z*GV%Rho0 * I_mass(i,j) - - if (KhCoeff*SN*I_H>0.) then + if (KhCoeff*SN*I_mass(i,j)>0.) then ! Solve resid(E) = 0, where resid = Kh(E) * (SN)^2 - damp_rate(E) E EKEmin = 0. ! Use the trivial root as the left bracket ResMin = 0. ! Need to detect direction of left residual @@ -839,7 +842,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! TODO: Should include resolution function in Kh Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) src = Kh * (SN * SN) - drag_rate = I_H * sqrt(drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + drag_rate = (GV%H_to_RZ * I_mass(i,j)) * sqrt(drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) ldamping = CS%MEKE_damping + drag_rate * bottomFac2 resid = src - ldamping * EKE ! if (debugIteration) then @@ -879,7 +882,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! TODO: Should include resolution function in Kh Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) src = Kh * (SN * SN) - drag_rate = I_H * sqrt( drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + drag_rate = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) ldamping = CS%MEKE_damping + drag_rate * bottomFac2 resid = src - ldamping * EKE if (useSecant .and. resid>ResMin) useSecant = .false. @@ -908,14 +911,15 @@ end subroutine MEKE_equilibrium !< This subroutine calculates a new equilibrium value for MEKE at each time step. This is not copied into !! MEKE%MEKE; rather, it is used as a restoring term to nudge MEKE%MEKE back to an equilibrium value -subroutine MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & +subroutine MEKE_equilibrium_restoring(CS, G, GV, US, SN_u, SN_v, depth_tot, & equilibrium_value) type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type. type(MEKE_CS), intent(in) :: CS !< MEKE control structure. real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: equilibrium_value !< Equilbrium value of MEKE to be calculated at each time step [L2 T-2 ~> m2 s-2] @@ -933,7 +937,7 @@ subroutine MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & ! SN = 0.25*max( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)), 0.) ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) - equilibrium_value(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * US%Z_to_L*depth_tot(i,j))**2 / cd2 + equilibrium_value(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * depth_tot(i,j))**2 / cd2 enddo ; enddo if (CS%id_MEKE_equilibrium>0) call post_data(CS%id_MEKE_equilibrium, equilibrium_value, CS%diag) @@ -952,7 +956,7 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: EKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: bottomFac2 !< gamma_b^2 [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: barotrFac2 !< gamma_t^2 [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: LmixScale !< Eddy mixing length [L ~> m]. @@ -962,11 +966,11 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & real :: SN ! The local Eady growth rate [T-1 ~> s-1] real :: FatH ! Coriolis parameter at h points [T-1 ~> s-1] real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] - real :: dZ_neglect ! A negligible change in height [Z ~> m] + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - dZ_neglect = GV%H_to_Z*GV%H_subroundoff + h_neglect = GV%H_subroundoff !$OMP do do j=js,je ; do i=is,ie @@ -988,14 +992,14 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & !### Consider different combinations of these estimates of topographic beta. beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i+1,j)-depth_tot(i,j)) * G%IdxCu(I,j) & - / max(depth_tot(i+1,j), depth_tot(i,j), dZ_neglect) & + / max(depth_tot(i+1,j), depth_tot(i,j), h_neglect) & + (depth_tot(i,j)-depth_tot(i-1,j)) * G%IdxCu(I-1,j) & - / max(depth_tot(i,j), depth_tot(i-1,j), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i-1,j), h_neglect) ) beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i,j+1)-depth_tot(i,j)) * G%IdyCv(i,J) & - / max(depth_tot(i,j+1), depth_tot(i,j), dZ_neglect) + & + / max(depth_tot(i,j+1), depth_tot(i,j), h_neglect) + & (depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) & - / max(depth_tot(i,j), depth_tot(i,j-1), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) ) endif beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & (G%dF_dy(i,j) + beta_topo_y)**2 ) @@ -1017,13 +1021,13 @@ end subroutine MEKE_lengthScales !> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ !! functions that are ratios of either bottom or barotropic eddy energy to the !! column eddy energy, respectively. See \ref section_MEKE_equations. -subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & +subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth_tot, Rd_dx, SN, EKE, & bottomFac2, barotrFac2, LmixScale, Lrhines, Leady) type(MEKE_CS), intent(in) :: CS !< MEKE control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: area !< Grid cell area [L2 ~> m2] real, intent(in) :: beta !< Planetary beta = \f$ \nabla f\f$ [T-1 L-1 ~> s-1 m-1] - real, intent(in) :: depth !< Ocean depth [Z ~> m] + real, intent(in) :: depth_tot !< The total thickness of the water column [H ~> m or kg m-2] real, intent(in) :: Rd_dx !< Resolution Ld/dx [nondim]. real, intent(in) :: SN !< Eady growth rate [T-1 ~> s-1]. real, intent(in) :: EKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2]. @@ -1039,7 +1043,7 @@ subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & ! Length scale for MEKE derived diffusivity Lgrid = sqrt(area) ! Grid scale Ldeform = Lgrid * Rd_dx ! Deformation scale - Lfrict = (US%Z_to_L * depth) / CS%cdrag ! Frictional arrest scale + Lfrict = depth_tot / CS%cdrag ! Frictional arrest scale ! gamma_b^2 is the ratio of bottom eddy energy to mean column eddy energy ! used in calculating bottom drag bottomFac2 = CS%MEKE_CD_SCALE**2 @@ -1248,7 +1252,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME call get_param(param_file, mdl, "MEKE_MIN_DEPTH_TOT", CS%MEKE_min_depth_tot, & "The minimum total depth over which to distribute MEKE energy sources. "//& "When the total depth is less than this, the sources are scaled away.", & - units="m", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%GM_src_alt) + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%GM_src_alt) call get_param(param_file, mdl, "MEKE_VISC_DRAG", CS%visc_drag, & "If true, use the vertvisc_type to calculate the bottom "//& "drag acting on MEKE.", default=.true.) @@ -1296,6 +1300,11 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME "If true, use the nominal bathymetric depth as the estimate of the "//& "time-varying ocean depth. Otherwise base the depth on the total ocean mass"//& "per unit area.", default=.true.) + call get_param(param_file, mdl, "MEKE_TOTAL_DEPTH_RHO", CS%rho_fixed_total_depth, & + "A density used to translate the nominal bathymetric depth into an estimate "//& + "of the total ocean mass per unit area when MEKE_FIXED_TOTAL_DEPTH is true.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(GV%Boussinesq.or.(.not.CS%fixed_total_depth))) call get_param(param_file, mdl, "MEKE_ALPHA_DEFORM", CS%aDeform, & "If positive, is a coefficient weighting the deformation scale "//& @@ -1348,7 +1357,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME "field to the bottom stress.", units="nondim", default=0.003) call get_param(param_file, mdl, "MEKE_CDRAG", CS%cdrag, & "Drag coefficient relating the magnitude of the velocity "//& - "field to the bottom stress in MEKE.", units="nondim", default=cdrag) + "field to the bottom stress in MEKE.", units="nondim", default=cdrag, scale=US%L_to_m*GV%m_to_H) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BIHARMONIC", biharmonic, default=.false., do_not_log=.true.) From d342b296fbaa94776cbbe3df1db131b3e10edb54 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Aug 2023 16:12:00 -0400 Subject: [PATCH 086/146] CI: Run test (and test.summary) locally The test.summary rule was causing errors in our Gitlab testing due to multiple runs (concurrent or otherwise) in the same workspace directory. This patch removes the WORKSPACE directory variable, and each .testing run happens in its own directory. Other minor changes: - The script to generate the summary was moved out of the Makefile and into a separate script. - Unrelated to these changes, error output was extended from 20 to 40 lines, to provide more readable backtrace output. --- .gitlab-ci.yml | 13 ++++----- .testing/Makefile | 33 +++++---------------- .testing/tools/report_test_results.sh | 42 +++++++++++++++++++++++++++ 3 files changed, 55 insertions(+), 33 deletions(-) create mode 100755 .testing/tools/report_test_results.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6be281c8cd..5bc90daca4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,6 @@ stages: # We use the "fetch" strategy to speed up the startup of stages variables: JOB_DIR: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/builds/$CI_PIPELINE_ID" - WORKSPACE: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/$CI_RUNNER_ID" GIT_STRATEGY: fetch # Always eport value of $JOB_DIR @@ -185,9 +184,9 @@ actions:gnu: - make -s -j - MPIRUN= make preproc -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" WORKSPACE=$WORKSPACE test -s -j') > job.sh - - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make WORKSPACE=$WORKSPACE test -s - - make WORKSPACE=$WORKSPACE test.summary + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh + - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make test -s + - make test.summary actions:intel: stage: tests @@ -205,9 +204,9 @@ actions:intel: - make -s -j - MPIRUN= make preproc -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" WORKSPACE=$WORKSPACE test -s -j') > job.sh - - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.intel.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make WORKSPACE=$WORKSPACE test -s - - make WORKSPACE=$WORKSPACE test.summary + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh + - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.intel.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make test -s + - make test.summary # Tests # diff --git a/.testing/Makefile b/.testing/Makefile index b877ecb5f2..d6b06893fe 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -554,8 +554,8 @@ $(WORKSPACE)/work/%/$(1)/ocean.stats $(WORKSPACE)/work/%/$(1)/chksum_diag: build && $(TIME) $(5) $(MPIRUN) -n $(6) $(abspath $$<) 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ - cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 20 ; \ - cat std.err | tee ../../../results/$$*/std.$(1).err | tail -n 20 ; \ + cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 40 ; \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail -n 40 ; \ rm ocean.stats chksum_diag ; \ echo -e "$(FAIL): $$*.$(1) failed at runtime." \ ) @@ -630,8 +630,8 @@ $(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc # Run the first half-period cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std1.err > std1.out \ || !( \ - cat std1.out | tee ../../../results/$*/std.restart1.out | tail -n 20 ; \ - cat std1.err | tee ../../../results/$*/std.restart1.err | tail -n 20 ; \ + cat std1.out | tee ../../../results/$*/std.restart1.out | tail -n 40 ; \ + cat std1.err | tee ../../../results/$*/std.restart1.err | tail -n 40 ; \ echo -e "$(FAIL): $*.restart failed at runtime." \ ) # Setup the next inputs @@ -641,8 +641,8 @@ $(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc # Run the second half-period cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std2.err > std2.out \ || !( \ - cat std2.out | tee ../../../results/$*/std.restart2.out | tail -n 20 ; \ - cat std2.err | tee ../../../results/$*/std.restart2.err | tail -n 20 ; \ + cat std2.out | tee ../../../results/$*/std.restart2.out | tail -n 40 ; \ + cat std2.err | tee ../../../results/$*/std.restart2.err | tail -n 40 ; \ echo -e "$(FAIL): $*.restart failed at runtime." \ ) @@ -652,26 +652,7 @@ $(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc # Not a true rule; only call this after `make test` to summarize test results. .PHONY: test.summary test.summary: - @if ls $(WORKSPACE)/results/*/* &> /dev/null; then \ - if ls $(WORKSPACE)/results/*/std.*.err &> /dev/null; then \ - echo "The following tests failed to complete:" ; \ - ls $(WORKSPACE)/results/*/std.*.out \ - | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ - fi; \ - if ls $(WORKSPACE)/results/*/ocean.stats.*.diff &> /dev/null; then \ - echo "The following tests report solution regressions:" ; \ - ls $(WORKSPACE)/results/*/ocean.stats.*.diff \ - | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[3]; if(length(t)>4) v=v"."t[4]; print a[2],":",v}'; \ - fi; \ - if ls $(WORKSPACE)/results/*/chksum_diag.*.diff &> /dev/null; then \ - echo "The following tests report diagnostic regressions:" ; \ - ls $(WORKSPACE)/results/*/chksum_diag.*.diff \ - | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ - fi; \ - false ; \ - else \ - echo -e "$(PASS): All tests passed!"; \ - fi + @./tools/report_test_results.sh $(WORKSPACE)/results #--- diff --git a/.testing/tools/report_test_results.sh b/.testing/tools/report_test_results.sh new file mode 100755 index 0000000000..24bab45507 --- /dev/null +++ b/.testing/tools/report_test_results.sh @@ -0,0 +1,42 @@ +#!/bin/sh +RESULTS=${1:-${PWD}/results} + +GREEN="\033[0;32m" +RESET="\033[0m" +PASS="${GREEN}PASS${RESET}" + +if [ -d ${RESULTS} ]; then + if ls ${RESULTS}/*/std.*.err &> /dev/null; then + echo "The following tests failed to complete:" + ls ${RESULTS}/*/std.*.out \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[2]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + if ls ${RESULTS}/*/ocean.stats.*.diff &> /dev/null; then + echo "The following tests report solution regressions:" + ls ${RESULTS}/*/ocean.stats.*.diff \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[3]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + if ls ${RESULTS}/*/chksum_diag.*.diff &> /dev/null; then + echo "The following tests report diagnostic regressions:" + ls ${RESULTS}/*/chksum_diag.*.diff \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[2]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + exit 1 +else + printf "${PASS}: All tests passed!\n" +fi From 9de6ce74d3d52882dcf1cfa69d5f2834d5610ed4 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 13 Jul 2023 11:03:15 -0400 Subject: [PATCH 087/146] New TIDAL_SAL_FLATHER option - This option is defaulted to False to retain previous answers, but should be set to True for new experiments in order to make the Flather OBC routine consistent with the barotropic solver - This option only applies for regional OBC cases with Tides and scalar self-attraction and loading + Try at fixing issue #476 - Will change answers for problems with OBCs. - Get Matt's patch to compile again Co-authored-by: Kate Hedstrom --- docs/zotero.bib | 13 +++++++++++++ src/core/MOM.F90 | 1 + src/core/MOM_barotropic.F90 | 33 +++++++++++++++++++++++++++------ 3 files changed, 41 insertions(+), 6 deletions(-) diff --git a/docs/zotero.bib b/docs/zotero.bib index 5acaee968a..c0f1ddccbb 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2747,3 +2747,16 @@ @article{Nguyen2009 title = {Improved modeling of the Arctic halocline with a subgrid-scale brine rejection parameterization}, pages = {C11014} } + +@article{Adcroft2019, + doi = {10.1029/2019ms001726}, + year = 2019, + publisher = {American Geophysical Union ({AGU})}, + volume = {11}, + number = {10}, + pages = {3167--3211}, + author = {A. Adcroft and W. Anderson and V. Balaji and C. Blanton and M. Bushuk and C. O. Dufour and J. P. Dunne and S. M. Griffies and R. Hallberg and M. J. Harrison and I. M. Held and M. F. Jansen and J. G. John and J. P. Krasting and A. R. Langenhorst and S. Legg and Z. Liang and C. McHugh and A. Radhakrishnan and B. G. Reichl and T. Rosati and B. L. Samuels and A. Shao and R. Stouffer and M. Winton and A. T. Wittenberg and B. Xiang and N. Zadeh and R. Zhang}, + title = {The {GFDL} Global Ocean and Sea Ice Model {OM}4.0: Model Description and Simulation Features}, + journal = {J. Adv. Mod. Earth Sys.} +} + diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d112de07b7..3013729109 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1619,6 +1619,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h, h_new, CS%ALE_CSp, CS%OBC, dzRegrid) if (associated(CS%OBC)) & + call pass_var(h_new, G%Domain) call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index e6f243a11c..4c600d37d2 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -279,6 +279,9 @@ module MOM_barotropic logical :: use_old_coriolis_bracket_bug !< If True, use an order of operations !! that is not bitwise rotationally symmetric in the !! meridional Coriolis term of the barotropic solver. + logical :: tidal_sal_flather !< Apply adjustment to external gravity wave speed + !! consistent with tidal self-attraction and loading + !! used within the barotropic solver type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate !! the timing of diagnostic output. @@ -1122,8 +1125,13 @@ 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, & - integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) + if (CS%TIDAL_SAL_FLATHER) then + call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & + integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) + else + call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & + integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) + endif endif ! Determine the difference between the sum of the layer fluxes and the @@ -3101,7 +3109,7 @@ 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, & - integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v) + integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) type(ocean_OBC_type), target, intent(inout) :: 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. @@ -3132,9 +3140,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used !! for a dynamic estimate of the face areas at !! v-points. - + real, intent(in), optional :: dgeo_de !< The constant of proportionality between + !! geopotential and sea surface height [nondim]. ! Local variables real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. + real :: dgeo_de_in !< The constant of proportionality between geopotential and sea surface height [nondim]. integer :: i, j, k, is, ie, js, je, n, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw @@ -3152,6 +3162,9 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B "yet fully implemented with wide barotropic halos.") endif + dgeo_de_in = 1.0 + if (PRESENT(dgeo_de)) dgeo_de_in = dgeo_de + if (.not. BT_OBC%is_alloced) then allocate(BT_OBC%Cg_u(isdw-1:iedw,jsdw:jedw), source=0.0) allocate(BT_OBC%H_u(isdw-1:iedw,jsdw:jedw), source=0.0) @@ -3210,7 +3223,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B BT_OBC%H_u(I,j) = eta(i+1,j) endif endif - BT_OBC%Cg_u(I,j) = SQRT(GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_u(i,j)) + BT_OBC%Cg_u(I,j) = SQRT(dgeo_de_in * GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_u(i,j)) endif endif ; enddo ; enddo if (OBC%Flather_u_BCs_exist_globally) then @@ -3264,7 +3277,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B BT_OBC%H_v(i,J) = eta(i,j+1) endif endif - BT_OBC%Cg_v(i,J) = SQRT(GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_v(i,J)) + BT_OBC%Cg_v(i,J) = SQRT(dgeo_de_in * GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_v(i,J)) endif endif ; enddo ; enddo if (OBC%Flather_v_BCs_exist_globally) then @@ -4520,6 +4533,14 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "solver has the wrong sign, replicating a long-standing bug with a scalar "//& "self-attraction and loading term or the SAL term from a previous simulation.", & default=.false., do_not_log=(det_de==0.0)) + call get_param(param_file, mdl, "TIDAL_SAL_FLATHER", CS%tidal_sal_flather, & + "If true, then apply adjustments to the external gravity "//& + "wave speed used with the Flather OBC routine consistent "//& + "with the barotropic solver. This applies to cases with "//& + "tidal forcing using the scalar self-attraction approximation. "//& + "The default is currently False in order to retain previous answers "//& + "but should be set to True for new experiments", default=.false.) + call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & "If true, the Coriolis terms are discretized with the "//& "Sadourny (1975) energy conserving scheme, otherwise "//& From 25b57f475adc648e2f69abb59a6ff875b59063e3 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 5 Sep 2023 22:53:17 -0400 Subject: [PATCH 088/146] makedep: Support externals alongside program units The current version of makedep uses the existence of program units (module or program) to determine whether a file contains globally accessible external functions. It incorrectly ignores files with externals it happens to contain both externals and a program unit. We resolve this by tracking whether we are inside or outside of a program unit while parsing each line. We ignore keywords which may appear in comments, as well as tokens which may contain `function` or `subroutine` as substrings. This method is not perfect; there are cases which will incorrectly report entering a block, but this method appears sufficient for all of our known codebases. This issue was detected when attempting to parse the AM2 source. While still far from a general solution, it is sufficient to handle a few of the more challenging cases encountered in AM2. --- ac/makedep | 45 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 39 insertions(+), 6 deletions(-) diff --git a/ac/makedep b/ac/makedep index 225a241b93..502250020b 100755 --- a/ac/makedep +++ b/ac/makedep @@ -16,6 +16,13 @@ re_use = re.compile(r"^ *use +([a-z_0-9]+)") re_cpp_include = re.compile(r"^ *# *include *[<\"']([a-zA-Z_0-9\.]+)[>\"']") re_f90_include = re.compile(r"^ *include +[\"']([a-zA-Z_0-9\.]+)[\"']") re_program = re.compile(r"^ *[pP][rR][oO][gG][rR][aA][mM] +([a-zA-Z_0-9]+)") +re_end = re.compile(r"^ *end *(module|procedure) ", re.IGNORECASE) +# NOTE: This excludes comments and tokens with substrings containing `function` +# or `subroutine`, but will fail if the keywords appear in other contexts. +re_procedure = re.compile( + r"^[^!]*(? 0: for h in cpp+inc: if h not in hlst and h in f2F.keys(): @@ -258,25 +266,49 @@ def scan_fortran_file(src_file): module_decl, used_modules, cpp_includes, f90_includes, programs = [], [], [], [], [] with io.open(src_file, 'r', errors='replace') as file: lines = file.readlines() + + external_namespace = True + + file_has_externals = False + for line in lines: match = re_module.match(line.lower()) if match: if match.group(1) not in 'procedure': # avoid "module procedure" statements module_decl.append(match.group(1)) + external_namespace = False + match = re_use.match(line.lower()) if match: used_modules.append(match.group(1)) + match = re_cpp_include.match(line) if match: cpp_includes.append(match.group(1)) + match = re_f90_include.match(line) if match: f90_includes.append(match.group(1)) + match = re_program.match(line) if match: programs.append(match.group(1)) + external_namespace = False + + match = re_end.match(line) + if match: + external_namespace = True + + # Check for any external procedures; if present, flag the file + # as a potential source of + # NOTE: This a very weak test that needs further modification + if external_namespace and not file_has_externals: + match = re_procedure.match(line) + if match: + file_has_externals = True + used_modules = [m for m in sorted(set(used_modules)) if m not in module_decl] - return add_suff(module_decl, '.mod'), add_suff(used_modules, '.mod'), cpp_includes, f90_includes, programs + return add_suff(module_decl, '.mod'), add_suff(used_modules, '.mod'), cpp_includes, f90_includes, programs, file_has_externals # return add_suff(module_decl, '.mod'), add_suff(sorted(set(used_modules)), '.mod'), cpp_includes, f90_includes, programs @@ -297,8 +329,9 @@ def find_files(src_dirs): for file in f: # TODO: use any() if (file.endswith('.F90') or file.endswith('.f90') + or file.endswith('.f') or file.endswith('.F') or file.endswith('.h') or file.endswith('.inc') - or file.endswith('.c')): + or file.endswith('.c') or file.endswith('.H')): files.append(p+'/'+file) return sorted(set(files)) From a7444b3d4dd42a6116206ae78949aab2d43ecd1b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 11 Jul 2023 16:03:24 -0400 Subject: [PATCH 089/146] *Test for convergence in dz_to_thickness_EOS Add tests to stop iterating when converged to roundoff in dz_to_thickness_EOS when in fully non-Boussinesq mode. Also modified the code to keep track of the layer thickness directly in non-Boussinesq mode rather than setting the layer thickness based on a difference between interface pressures. Boussinesq answers are bitwise identical, but non-Boussinesq answers change. --- src/core/MOM_interface_heights.F90 | 45 ++++++++++++++++++++++-------- 1 file changed, 33 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 0a579db299..194c39c76d 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -519,10 +519,15 @@ subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_s ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & p_top, p_bot ! Pressure at the interfaces above and below a layer [R L2 T-2 ~> Pa] + real :: dp(SZI_(G),SZJ_(G)) ! Pressure change across a layer [R L2 T-2 ~> Pa] real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2] real :: rho(SZI_(G)) ! The in situ density [R ~> kg m-3] + real :: dp_adj ! The amount by which to change the bottom pressure in an + ! iteration [R L2 T-2 ~> Pa] real :: I_gEarth ! Unit conversion factors divided by the gravitational ! acceleration [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] + logical :: do_more(SZI_(G),SZJ_(G)) ! If true, additional iterations would be beneficial. + logical :: do_any ! True if there are points in this layer that need more itertions. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, halo, nz integer :: itt, max_itt @@ -561,38 +566,54 @@ subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_s if (GV%semi_Boussinesq) then do i=is,ie p_bot(i,j) = p_top(i,j) + (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) + dp(i,j) = (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) enddo else do i=is,ie p_bot(i,j) = p_top(i,j) + rho(i) * (GV%g_Earth * dz(i,j,k)) + dp(i,j) = rho(i) * (GV%g_Earth * dz(i,j,k)) enddo endif enddo + do_more(:,:) = .true. do itt=1,max_itt - call int_specific_vol_dp(Temp(:,:,k), Saln(:,:,k), p_top, p_bot, 0.0, G%HI, & - EoS, US, dz_geo) + do_any = .false. + call int_specific_vol_dp(Temp(:,:,k), Saln(:,:,k), p_top, p_bot, 0.0, G%HI, EoS, US, dz_geo) if (itt < max_itt) then ; do j=js,je - call calculate_density(Temp(:,j,k), Saln(:,j,k), p_bot(:,j), rho, & - EoS, EOSdom) + call calculate_density(Temp(:,j,k), Saln(:,j,k), p_bot(:,j), rho, EoS, EOSdom) ! Use Newton's method to correct the bottom value. ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. if (GV%semi_Boussinesq) then do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) + dp_adj = rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + dp_adj + dp(i,j) = dp(i,j) + dp_adj enddo + do_any = .true. ! To avoid changing answers, always use the maximum number of itertions. else - do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * (GV%g_Earth*dz(i,j,k) - dz_geo(i,j)) - enddo + do i=is,ie ; if (do_more(i,j)) then + dp_adj = rho(i) * (GV%g_Earth*dz(i,j,k) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + dp_adj + dp(i,j) = dp(i,j) + dp_adj + ! Check for convergence to roundoff. + do_more(i,j) = (abs(dp_adj) > 1.0e-15*dp(i,j)) + if (do_more(i,j)) do_any = .true. + endif ; enddo endif enddo ; endif + if (.not.do_any) exit enddo - do j=js,je ; do i=is,ie - !### This code should be revised to use a dp variable for accuracy. - h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth - enddo ; enddo + if (GV%semi_Boussinesq) then + do j=js,je ; do i=is,ie + h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth + enddo ; enddo + else + do j=js,je ; do i=is,ie + h(i,j,k) = dp(i,j) * I_gEarth + enddo ; enddo + endif enddo endif From dd5c47d031ee0c7dbba3e7f7770d81175a943032 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 14 Aug 2023 09:57:13 -0400 Subject: [PATCH 090/146] *Non-Boussinesq revision of energetic_PBL This commit revises the internal routines called by energetic_PBL to work in fully non-Boussinesq mode, eliminating all dependencies on the Boussinesq reference density when in non-Boussinesq mode. The publicly visible interfaces to this module and the external routines it calls have already been revised, so only this file needs to be updated. The specific changes include: - Work with both thickness (h) and height change (dz) variables in energetic_PBL using thickness_to_dz to translate between the two. In Boussinesq mode, these are a simple rescaling by a constant factor, but in non-Boussinesq mode they vary by a factor of the specific volume. Some calculations are unnecessarily duplicated in Boussinesq mode, so this might slow the model slightly, but they are not duplicative in non-Boussinesq mode. - When in non-Boussinesq mode, use forces%tau_mag and tv%SpV_avg instead of forces%ustar and GV%Rho0 to determine the friction velocity and mechanical TKE input used in energetic_PBL, and to convert the local TKE to a turbulent velocity. This includes the addition of a new energy input argument and an interface specific volume argument to ePBL_column and the removal of an unused argument to find_mstar. - Use tau_mag_gustless times the in situ specfic volume instead of ustar_gustless to calculate the Langmuir number used by ePBL when it is run in non-Boussinesq mode. - The unused Ustar_mean argument to find_mstar was removed. This change involves the addition of 2 new arguments to ePBL_column and changes to the units of another argument. There are changes to the units of 2 elements of the energetic_PBL_CS type and 14 internal variables. This change includes the addition of 13 new internal variables, the removal of 8 internal variable (most of which were renamed to reflect their new units). With this change, 9 thickness to height conversion factors have been eliminated, and GV%Rho0 is only used in Boussinesq mode. All answers in Boussinesq mode are bitwise identical, but they change in non-Boussinesq mode cases that use ePBL, which no longer depend on the value of the Boussinesq reference density. --- .../vertical/MOM_energetic_PBL.F90 | 302 +++++++++++------- 1 file changed, 186 insertions(+), 116 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 17da7aceb3..380725b744 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -3,20 +3,20 @@ module MOM_energetic_PBL ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE -use MOM_coms, only : EFP_type, real_to_EFP, EFP_to_real, operator(+), assignment(=), EFP_sum_across_PEs -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc -use MOM_diag_mediator, only : time_type, diag_ctrl -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_coms, only : EFP_type, real_to_EFP, EFP_to_real, operator(+), assignment(=), EFP_sum_across_PEs +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc +use MOM_diag_mediator, only : time_type, diag_ctrl +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : thickness_to_dz use MOM_string_functions, only : uppercase -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_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_interface, only : wave_parameters_CS, Get_Langmuir_Number use MOM_stochastics, only : stochastic_CS @@ -76,7 +76,7 @@ module MOM_energetic_PBL !! boundary layer thickness [nondim]. The default is 0, but a !! value of 0.1 might be better justified by observations. real :: MLD_tol !< A tolerance for determining the boundary layer thickness when - !! Use_MLD_iteration is true [H ~> m or kg m-2]. + !! Use_MLD_iteration is true [Z ~> m]. real :: min_mix_len !< The minimum mixing length scale that will be used by ePBL [Z ~> m]. !! The default (0) does not set a minimum. @@ -170,7 +170,7 @@ module MOM_energetic_PBL !! timing of diagnostic output. real, allocatable, dimension(:,:) :: & - ML_depth !< The mixed layer depth determined by active mixing in ePBL [Z ~> m]. + ML_depth !< The mixed layer depth determined by active mixing in ePBL [H ~> m or kg m-2] ! These are terms in the mixed layer TKE budget, all in [R Z3 T-3 ~> W m-2 = kg s-3]. real, allocatable, dimension(:,:) :: & diag_TKE_wind, & !< The wind source of TKE [R Z3 T-3 ~> W m-2]. @@ -319,7 +319,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS u_2d, & ! A 2-d slice of the zonal velocity [L T-1 ~> m s-1]. v_2d ! A 2-d slice of the meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK_(GV)+1) :: & - Kd_2d ! A 2-d version of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + Kd_2d ! A 2-d version of the diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZK_(GV)) :: & h, & ! The layer thickness [H ~> m or kg m-2]. dz, & ! The vertical distance across layers [Z ~> m]. @@ -331,17 +331,25 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS u, & ! The zonal velocity [L T-1 ~> m s-1]. v ! The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZK_(GV)+1) :: & - Kd, & ! The diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + Kd, & ! The diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. mixvel, & ! A turbulent mixing velocity [Z T-1 ~> m s-1]. - mixlen ! A turbulent mixing length [Z ~> m]. + mixlen, & ! A turbulent mixing length [Z ~> m]. + SpV_dt ! Specific volume interpolated to interfaces divided by dt or 1.0 / (dt * Rho0) + ! times conversion factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1], + ! used to convert local TKE into a turbulence velocity cubed. 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 :: absf ! The absolute value of f [T-1 ~> s-1]. real :: U_star ! The surface friction velocity [Z T-1 ~> m s-1]. real :: U_Star_Mean ! The surface friction without gustiness [Z T-1 ~> m s-1]. + real :: mech_TKE ! The mechanically generated turbulent kinetic energy available for mixing over a + ! timestep before the application of the efficiency in mstar [R Z3 T-2 ~> J m-2] + real :: I_rho ! The inverse of the Boussinesq reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] + real :: I_dt ! The Adcroft reciprocal of the timestep [T-1 ~> s-1] real :: B_Flux ! The surface buoyancy flux [Z2 T-3 ~> m2 s-3] - real :: MLD_io ! The mixed layer depth found by ePBL_column [Z ~> m]. + real :: MLD_io ! The mixed layer depth found by ePBL_column [Z ~> m] type(ePBL_column_diags) :: eCD ! A container for passing around diagnostics. @@ -354,14 +362,18 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & "energetic_PBL: Temperature, salinity and an equation of state "//& "must now be used.") - if (.NOT. associated(fluxes%ustar)) call MOM_error(FATAL, & - "energetic_PBL: No surface TKE fluxes (ustar) defined in fluxes type!") + if (.not.(associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "energetic_PBL: No surface friction velocity (ustar or tau_mag) defined in fluxes type.") + if ((.not.GV%Boussinesq) .and. (.not.associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "energetic_PBL: No surface wind stress magnitude defined in fluxes type in non-Boussinesq mode.") if (CS%use_LT .and. .not.associated(Waves)) call MOM_error(FATAL, & "energetic_PBL: The Waves control structure must be associated if CS%use_LT "//& "(i.e., USE_LA_LI2016 or EPBL_LT) is True.") h_neglect = GV%H_subroundoff + I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 ! This is not used when fully non-Boussinesq. + I_dt = 0.0 ; if (dt > 0.0) I_dt = 1.0 / dt ! Zero out diagnostics before accumulation. if (CS%TKE_diagnostics) then @@ -376,7 +388,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! if (CS%id_Mixing_Length>0) CS%Mixing_Length(:,:,:) = 0.0 ! if (CS%id_Velocity_Scale>0) CS%Velocity_Scale(:,:,:) = 0.0 - !!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt, & + !!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt,I_dt, & !!OMP CS,G,GV,US,fluxes,TKE_forced,dSV_dT,dSV_dS,Kd_int) do j=js,je ! Copy the thicknesses and other fields to 2-d arrays. @@ -388,6 +400,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS enddo ; enddo call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) + ! Set the inverse density used to translating local TKE into a turbulence velocity + SpV_dt(:) = 0.0 + if ((dt > 0.0) .and. GV%Boussinesq .or. .not.allocated(tv%SpV_avg)) then + do K=1,nz+1 + SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) + enddo + endif + ! Determine the initial mech_TKE and conv_PErel, including the energy required ! to mix surface heating through the topmost cell, the energy released by mixing ! surface cooling & brine rejection down through the topmost cell, and @@ -406,8 +426,29 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS do K=1,nz+1 ; Kd(K) = 0.0 ; enddo ! Make local copies of surface forcing and process them. - u_star = fluxes%ustar(i,j) - u_star_Mean = fluxes%ustar_gustless(i,j) + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + u_star = fluxes%ustar(i,j) + u_star_Mean = fluxes%ustar_gustless(i,j) + mech_TKE = dt * GV%Rho0 * u_star**3 + elseif (allocated(tv%SpV_avg)) then + u_star = sqrt(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + u_star_Mean = sqrt(US%L_to_Z*fluxes%tau_mag_gustless(i,j) * tv%SpV_avg(i,j,1)) + mech_TKE = dt * u_star * US%L_to_Z*fluxes%tau_mag(i,j) + else + u_star = sqrt(fluxes%tau_mag(i,j) * I_rho) + u_star_Mean = sqrt(US%L_to_Z*fluxes%tau_mag_gustless(i,j) * I_rho) + mech_TKE = dt * GV%Rho0 * u_star**3 + ! The line above is equivalent to: mech_TKE = dt * u_star * US%L_to_Z*fluxes%tau_mag(i,j) + endif + + if (allocated(tv%SpV_avg) .and. .not.GV%Boussinesq) then + SpV_dt(1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,1) * I_dt + do K=2,nz + SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) * 0.5*(tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) * I_dt + enddo + SpV_dt(nz+1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,nz) * I_dt + endif + B_flux = buoy_flux(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then if (fluxes%frac_shelf_h(i,j) > 0.0) & @@ -429,13 +470,13 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (CS%MLD_iteration_guess .and. (CS%ML_depth(i,j) > 0.0)) MLD_io = CS%ML_depth(i,j) if (stoch_CS%pert_epbl) then ! stochastics are active - call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j, & TKE_gen_stoch=stoch_CS%epbl1_wts(i,j), TKE_diss_stoch=stoch_CS%epbl2_wts(i,j)) else - call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j) endif @@ -472,7 +513,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS CS%ML_depth(i,j) = 0.0 endif ; enddo ! Close of i-loop - Note unusual loop order! - do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = GV%Z_to_H*Kd_2d(i,K) ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = Kd_2d(i,K) ; enddo ; enddo enddo ! j-loop @@ -504,8 +545,8 @@ end subroutine energetic_PBL !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model for a single column of water. -subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & +subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE_in, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & Waves, G, i, j, TKE_gen_stoch, TKE_diss_stoch) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -523,6 +564,10 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, !! [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZK_(GV)), intent(in) :: dSV_dS !< The partial derivative of in-situ specific !! volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + real, dimension(SZK_(GV)+1), intent(in) :: SpV_dt !< Specific volume interpolated to interfaces + !! divided by dt or 1.0 / (dt * Rho0) times conversion + !! factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1], + !! used to convert local TKE into a turbulence velocity. real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. @@ -531,12 +576,16 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. real, intent(in) :: u_star_mean !< The surface friction velocity without any !! contribution from unresolved gustiness [Z T-1 ~> m s-1]. + real, intent(in) :: mech_TKE_in !< The mechanically generated turbulent + !! kinetic energy available for mixing over a time + !! step before the application of the efficiency + !! in mstar. [R Z3 T-2 ~> J m-2]. real, intent(inout) :: MLD_io !< A first guess at the mixed layer depth on input, and - !! the calculated mixed layer depth on output [Z ~> m]. + !! the calculated mixed layer depth on output [Z ~> m] real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZK_(GV)+1), & intent(out) :: Kd !< The diagnosed diffusivities at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZK_(GV)+1), & intent(out) :: mixvel !< The mixing velocity scale used in Kd !! [Z T-1 ~> m s-1]. @@ -575,11 +624,12 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, real :: conv_PErel ! The potential energy that has been convectively released ! during this timestep [R Z3 T-2 ~> J m-2]. A portion nstar_FC ! of conv_PErel is available to drive mixing. - real :: htot ! The total depth of the layers above an interface [H ~> m or kg m-2]. + real :: htot ! The total thickness of the layers above an interface [H ~> m or kg m-2]. + real :: dztot ! The total depth of the layers above an interface [Z ~> m]. real :: uhtot ! The depth integrated zonal velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] real :: vhtot ! The depth integrated meridional velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] real :: Idecay_len_TKE ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. - real :: h_sum ! The total thickness of the water column [H ~> m or kg m-2]. + real :: dz_sum ! The total thickness of the water column [Z ~> m]. real, dimension(SZK_(GV)) :: & dT_to_dColHt, & ! Partial derivative of the total column height with the temperature changes @@ -619,6 +669,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, MixLen_shape, & ! A nondimensional shape factor for the mixing length that ! gives it an appropriate asymptotic value at the bottom of ! the boundary layer [nondim]. + h_dz_int, & ! The ratio of the layer thicknesses over the vertical distances + ! across the layers surrounding an interface [H Z-1 ~> nondim or kg m-3] Kddt_h ! The diapycnal diffusivity times a timestep divided by the ! average thicknesses around a layer [H ~> m or kg m-2]. real :: b1 ! b1 is inverse of the pivot used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. @@ -627,6 +679,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! in the denominator of b1 in a downward-oriented tridiagonal solver. 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 :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: dMass ! The mass per unit area within a layer [Z R ~> kg m-2]. real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa = J m-3]. real :: dMKE_max ! The maximum amount of mean kinetic energy that could be @@ -637,28 +691,25 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! of a layer and the thickness of the water above, used in ! the MKE conversion equation [H-1 ~> m-1 or m2 kg-1]. - real :: dt_h ! The timestep divided by the averages of the thicknesses around - ! a layer, times a thickness conversion factor [H T Z-2 ~> s m-1 or kg s m-4]. - real :: h_bot ! The distance from the bottom [H ~> m or kg m-2]. - real :: h_rsum ! The running sum of h from the top [H ~> m or kg m-2]. - real :: I_hs ! The inverse of h_sum [H-1 ~> m-1 or m2 kg-1]. - real :: I_MLD ! The inverse of the current value of MLD [H-1 ~> m-1 or m2 kg-1]. - real :: h_tt ! The distance from the surface or up to the next interface + real :: dt_h ! The timestep divided by the averages of the vertical distances around + ! a layer [T Z-1 ~> s m-1]. + real :: dz_bot ! The distance from the bottom [Z ~> m]. + real :: dz_rsum ! The running sum of dz from the top [Z ~> m]. + real :: I_dzsum ! The inverse of dz_sum [Z-1 ~> m-1]. + real :: I_MLD ! The inverse of the current value of MLD [Z-1 ~> m-1]. + real :: dz_tt ! The distance from the surface or up to the next interface ! that did not exhibit turbulent mixing from this scheme plus - ! a surface mixing roughness length given by h_tt_min [H ~> m or kg m-2]. - real :: h_tt_min ! A surface roughness length [H ~> m or kg m-2]. + ! a surface mixing roughness length given by dz_tt_min [Z ~> m]. + real :: dz_tt_min ! A surface roughness length [Z ~> m]. real :: C1_3 ! = 1/3 [nondim] - real :: I_dtrho ! 1.0 / (dt * Rho0) times conversion factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1]. - ! This is used convert TKE back into ustar^3 for use in a cube root. real :: vstar ! An in-situ turbulent velocity [Z T-1 ~> m s-1]. real :: mstar_total ! The value of mstar used in ePBL [nondim] real :: mstar_LT ! An addition to mstar due to Langmuir turbulence [nondim] (output for diagnostic) - real :: MLD_output ! The mixed layer depth output from this routine [H ~> m or kg m-2]. + real :: MLD_output ! The mixed layer depth output from this routine [Z ~> m] real :: LA ! The value of the Langmuir number [nondim] real :: LAmod ! The modified Langmuir number by convection [nondim] - real :: hbs_here ! The local minimum of hb_hs and MixLen_shape, times a - ! conversion factor from H to Z [Z H-1 ~> nondim or m3 kg-1]. + real :: hbs_here ! The local minimum of hb_hs and MixLen_shape [nondim] real :: nstar_FC ! The fraction of conv_PErel that can be converted to mixing [nondim]. real :: TKE_reduc ! The fraction by which TKE and other energy fields are ! reduced to support mixing [nondim]. between 0 and 1. @@ -677,7 +728,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, real :: dPE_conv ! The convective change in column potential energy [R Z3 T-2 ~> J m-2]. real :: MKE_src ! The mean kinetic energy source of TKE due to Kddt_h(K) [R Z3 T-2 ~> J m-2]. real :: dMKE_src_dK ! The partial derivative of MKE_src with Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. - real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: PE_chg_g0 ! The potential energy change when Kd is Kd_guess0 [R Z3 T-2 ~> J m-2] real :: Kddt_h_g0 ! The first guess diapycnal diffusivity times a timestep divided ! by the average thicknesses around a layer [H ~> m or kg m-2]. @@ -706,15 +757,14 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, logical :: sfc_disconnect ! If true, any turbulence has become disconnected ! from the surface. -! The following are only used for diagnostics. + ! The following is only used for diagnostics. real :: I_dtdiag ! = 1.0 / dt [T-1 ~> s-1]. !---------------------------------------------------------------------- !/BGR added Aug24,2016 for adding iteration to get boundary layer depth ! - needed to compute new mixing length. - real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration [H ~> m or kg m-2]. - real :: MLD_guess_Z ! A guessed mixed layer depth, converted to height units [Z ~> m] - real :: min_MLD, max_MLD ! Iteration bounds on MLD [H ~> m or kg m-2], which are adjusted at each step + real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration [Z ~> m] + real :: min_MLD, max_MLD ! Iteration bounds on MLD [Z ~> m], which are adjusted at each step ! - These are initialized based on surface/bottom ! 1. The iteration guesses a value (possibly from prev step or neighbor). ! 2. The iteration checks if value is converged, too shallow, or too deep. @@ -727,8 +777,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! manner giving a usable guess. When it does fail, it is due to convection ! within the boundary layer. Likely, a new method e.g. surface_disconnect, ! can improve this. - real :: dMLD_min ! The change in diagnosed mixed layer depth when the guess is min_MLD [H ~> m or kg m-2] - real :: dMLD_max ! The change in diagnosed mixed layer depth when the guess is max_MLD [H ~> m or kg m-2] + real :: dMLD_min ! The change in diagnosed mixed layer depth when the guess is min_MLD [Z ~> m] + real :: dMLD_max ! The change in diagnosed mixed layer depth when the guess is max_MLD [Z ~> m] logical :: OBL_converged ! Flag for convergence of MLD integer :: OBL_it ! Iteration counter @@ -762,16 +812,16 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, calc_Te = (debug .or. (.not.CS%orig_PE_calc)) h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff C1_3 = 1.0 / 3.0 I_dtdiag = 1.0 / dt max_itt = 20 - h_tt_min = 0.0 - I_dtrho = 0.0 ; if (dt*GV%Rho0 > 0.0) I_dtrho = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) + dz_tt_min = 0.0 vstar_unit_scale = US%m_to_Z * US%T_to_s - MLD_guess = MLD_io*GV%Z_to_H + MLD_guess = MLD_io ! Determine the initial mech_TKE and conv_PErel, including the energy required ! to mix surface heating through the topmost cell, the energy released by mixing @@ -794,29 +844,39 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, pres_Z(K+1) = pres_Z(K) + dPres enddo - ! Determine the total thickness (h_sum) and the fractional distance from the bottom (hb_hs). - h_sum = H_neglect ; do k=1,nz ; h_sum = h_sum + h(k) ; enddo - I_hs = 0.0 ; if (h_sum > 0.0) I_hs = 1.0 / h_sum - h_bot = 0.0 + ! Determine the total thickness (dz_sum) and the fractional distance from the bottom (hb_hs). + dz_sum = dz_neglect ; do k=1,nz ; dz_sum = dz_sum + dz(k) ; enddo + I_dzsum = 0.0 ; if (dz_sum > 0.0) I_dzsum = 1.0 / dz_sum + dz_bot = 0.0 hb_hs(nz+1) = 0.0 do k=nz,1,-1 - h_bot = h_bot + h(k) - hb_hs(K) = h_bot * I_hs + dz_bot = dz_bot + dz(k) + hb_hs(K) = dz_bot * I_dzsum enddo - MLD_output = h(1) + MLD_output = dz(1) !/The following lines are for the iteration over MLD ! max_MLD will initialized as ocean bottom depth - max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + h(k) ; enddo + max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + dz(k) ; enddo ! min_MLD will be initialized to 0. min_MLD = 0.0 ! Set values of the wrong signs to indicate that these changes are not based on valid estimates - dMLD_min = -1.0*GV%m_to_H ; dMLD_max = 1.0*GV%m_to_H + dMLD_min = -1.0*US%m_to_Z ; dMLD_max = 1.0*US%m_to_Z ! If no first guess is provided for MLD, try the middle of the water column if (MLD_guess <= min_MLD) MLD_guess = 0.5 * (min_MLD + max_MLD) + if (GV%Boussinesq) then + do K=1,nz+1 ; h_dz_int(K) = GV%Z_to_H ; enddo + else + h_dz_int(1) = (h(1) + h_neglect) / (dz(1) + dz_neglect) + do K=2,nz + h_dz_int(K) = (h(k-1) + h(k) + h_neglect) / (dz(k-1) + dz(k) + dz_neglect) + enddo + h_dz_int(nz+1) = (h(nz) + h_neglect) / (dz(nz) + dz_neglect) + endif + ! Iterate to determine a converged EPBL depth. OBL_converged = .false. do OBL_it=1,CS%Max_MLD_Its @@ -828,26 +888,26 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, if (debug) then ; mech_TKE_k(:) = 0.0 ; conv_PErel_k(:) = 0.0 ; endif ! Reset ML_depth - MLD_output = h(1) + MLD_output = dz(1) sfc_connected = .true. !/ Here we get MStar, which is the ratio of convective TKE driven mixing to UStar**3 - MLD_guess_z = GV%H_to_Z*MLD_guess ! Convert MLD from thickness to height coordinates for these calls if (CS%Use_LT) then - call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess_z), u_star_mean, i, j, dz, Waves, & + call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess), u_star_mean, i, j, dz, Waves, & U_H=u, V_H=v) - call find_mstar(CS, US, B_flux, u_star, u_star_Mean, MLD_guess_z, absf, & + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, & MStar_total, Langmuir_Number=La, Convect_Langmuir_Number=LAmod,& mstar_LT=mstar_LT) else - call find_mstar(CS, US, B_flux, u_star, u_star_mean, MLD_guess_z, absf, mstar_total) + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, mstar_total) endif !/ Apply MStar to get mech_TKE if ((CS%answer_date < 20190101) .and. (CS%mstar_scheme==Use_Fixed_MStar)) then mech_TKE = (dt*MSTAR_total*GV%Rho0) * u_star**3 else - mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) + mech_TKE = MSTAR_total * mech_TKE_in + ! mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically perturb mech_TKE in the UFS if (present(TKE_gen_stoch)) mech_TKE = mech_TKE*TKE_gen_stoch @@ -894,16 +954,16 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! Reduce the mixing length based on MLD, with a quadratic ! expression that follows KPP. I_MLD = 1.0 / MLD_guess - h_rsum = 0.0 + dz_rsum = 0.0 MixLen_shape(1) = 1.0 do K=2,nz+1 - h_rsum = h_rsum + h(k-1) + dz_rsum = dz_rsum + dz(k-1) if (CS%MixLenExponent==2.0) then MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & - (max(0.0, (MLD_guess - h_rsum)*I_MLD) )**2 ! CS%MixLenExponent + (max(0.0, (MLD_guess - dz_rsum)*I_MLD) )**2 ! CS%MixLenExponent else MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & - (max(0.0, (MLD_guess - h_rsum)*I_MLD) )**CS%MixLenExponent + (max(0.0, (MLD_guess - dz_rsum)*I_MLD) )**CS%MixLenExponent endif enddo endif @@ -913,7 +973,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, dT_to_dPE_a(1) = dT_to_dPE(1) ; dT_to_dColHt_a(1) = dT_to_dColHt(1) dS_to_dPE_a(1) = dS_to_dPE(1) ; dS_to_dColHt_a(1) = dS_to_dColHt(1) - htot = h(1) ; uhtot = u(1)*h(1) ; vhtot = v(1)*h(1) + htot = h(1) ; dztot = dz(1) ; uhtot = u(1)*h(1) ; vhtot = v(1)*h(1) if (debug) then mech_TKE_k(1) = mech_TKE ; conv_PErel_k(1) = conv_PErel @@ -928,7 +988,11 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! different rates. The following form is often used for mechanical ! stirring from the surface, perhaps due to breaking surface gravity ! waves and wind-driven turbulence. - Idecay_len_TKE = (CS%TKE_decay * absf / u_star) * GV%H_to_Z + if (GV%Boussinesq) then + Idecay_len_TKE = (CS%TKE_decay * absf / u_star) * GV%H_to_Z + else + Idecay_len_TKE = (CS%TKE_decay * absf) / (h_dz_int(K) * u_star) + endif exp_kh = 1.0 if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & @@ -956,9 +1020,14 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, if (CS%nstar * conv_PErel > 0.0) then ! Here nstar is a function of the natural Rossby number 0.2/(1+0.2/Ro), based ! on a curve fit from the data of Wang (GRL, 2003). - ! Note: Ro = 1.0 / sqrt(0.5 * dt * Rho0 * (absf*htot)**3 / conv_PErel) - nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & - sqrt(0.5 * dt * GV%Rho0 * (absf*(htot*GV%H_to_Z))**3 * conv_PErel)) + ! Note: Ro = 1.0 / sqrt(0.5 * dt * Rho0 * (absf*dztot)**3 / conv_PErel) + if (GV%Boussinesq) then + nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & + sqrt(0.5 * dt * GV%Rho0 * (absf*dztot)**3 * conv_PErel)) + else + nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & + sqrt(0.5 * dt * GV%H_to_RZ * (absf**3 * (dztot**2 * htot)) * conv_PErel)) + endif endif if (debug) nstar_k(K) = nstar_FC @@ -1001,7 +1070,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) endif endif - dt_h = (GV%Z_to_H**2*dt) / max(0.5*(h(k-1)+h(k)), 1e-15*h_sum) + dt_h = dt / max(0.5*(dz(k-1)+dz(k)), 1e-15*dz_sum) ! This tests whether the layers above and below this interface are in ! a convectively stable configuration, without considering any effects of @@ -1088,26 +1157,26 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! At this point, Kddt_h(K) will be unknown because its value may depend ! on how much energy is available. mech_TKE might be negative due to ! contributions from TKE_forced. - h_tt = htot + h_tt_min + dz_tt = dztot + dz_tt_min TKE_here = mech_TKE + CS%wstar_ustar_coef*conv_PErel if (TKE_here > 0.0) then if (CS%wT_scheme==wT_from_cRoot_TKE) then - vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1.0 - htot / MLD_guess) + Surface_Scale = max(0.05, 1.0 - dztot / MLD_guess) vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & - vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) endif - hbs_here = GV%H_to_Z * min(hb_hs(K), MixLen_shape(K)) - mixlen(K) = MAX(CS%min_mix_len, ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar)) + hbs_here = min(hb_hs(K), MixLen_shape(K)) + mixlen(K) = MAX(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar)) !Note setting Kd_guess0 to vstar * CS%vonKar * mixlen(K) here will ! change the answers. Therefore, skipping that. if (.not.CS%Use_MLD_iteration) then - Kd_guess0 = vstar * CS%vonKar * ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar) + Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) else - Kd_guess0 = vstar * CS%vonKar * mixlen(K) + Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) endif else vstar = 0.0 ; Kd_guess0 = 0.0 @@ -1141,22 +1210,22 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, TKE_here = mech_TKE + CS%wstar_ustar_coef*(conv_PErel-PE_chg_max) if (TKE_here > 0.0) then if (CS%wT_scheme==wT_from_cRoot_TKE) then - vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1. - htot / MLD_guess) + Surface_Scale = max(0.05, 1. - dztot / MLD_guess) vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & - vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) endif - hbs_here = GV%H_to_Z * min(hb_hs(K), MixLen_shape(K)) - mixlen(K) = max(CS%min_mix_len, ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar)) + hbs_here = min(hb_hs(K), MixLen_shape(K)) + mixlen(K) = max(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar)) if (.not.CS%Use_MLD_iteration) then ! Note again (as prev) that using mixlen here ! instead of redoing the computation will change answers... - Kd(K) = vstar * CS%vonKar * ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar) + Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) else - Kd(K) = vstar * CS%vonKar * mixlen(K) + Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) endif else vstar = 0.0 ; Kd(K) = 0.0 @@ -1196,7 +1265,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag endif if (sfc_connected) then - MLD_output = MLD_output + h(k) + MLD_output = MLD_output + dz(k) endif Kddt_h(K) = Kd(K) * dt_h @@ -1220,7 +1289,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, mech_TKE = TKE_reduc*(mech_TKE + MKE_src) conv_PErel = TKE_reduc*conv_PErel if (sfc_connected) then - MLD_output = MLD_output + h(k) + MLD_output = MLD_output + dz(k) endif elseif (tot_TKE == 0.0) then @@ -1320,8 +1389,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, (CS%nstar-nstar_FC) * conv_PErel * I_dtdiag endif - if (sfc_connected) MLD_output = MLD_output + & - (PE_chg / (PE_chg_g0)) * h(k) + if (sfc_connected) MLD_output = MLD_output + (PE_chg / (PE_chg_g0)) * dz(k) tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 sfc_disconnect = .true. @@ -1351,11 +1419,13 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, uhtot = u(k)*h(k) vhtot = v(k)*h(k) htot = h(k) + dztot = dz(k) sfc_connected = .false. else uhtot = uhtot + u(k)*h(k) vhtot = vhtot + v(k)*h(k) htot = htot + h(k) + dztot = dztot + dz(k) endif if (calc_Te) then @@ -1416,7 +1486,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! Taking the occasional step with MLD_output empirically helps to converge faster. if ((dMLD_min > 0.0) .and. (dMLD_max < 0.0) .and. (OBL_it > 2) .and. (mod(OBL_it-1,4) > 0)) then ! Both bounds have valid change estimates and are probably in the range of possible outputs. - MLD_Guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) + MLD_guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) elseif ((MLD_found > min_MLD) .and. (MLD_found < max_MLD)) then ! The output MLD_found is an interesting guess, as it likely to bracket the true solution ! along with the previous value of MLD_guess and to be close to the solution. @@ -1440,7 +1510,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, eCD%LA = 0.0 ; eCD%LAmod = 0.0 ; eCD%mstar = mstar_total ; eCD%mstar_LT = 0.0 endif - MLD_io = GV%H_to_Z*MLD_output + MLD_io = MLD_output end subroutine ePBL_column @@ -1746,13 +1816,12 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & end subroutine find_PE_chg_orig !> This subroutine finds the Mstar value for ePBL -subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& +subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, & BLD, Abs_Coriolis, MStar, Langmuir_Number,& MStar_LT, Convect_Langmuir_Number) type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: UStar !< ustar w/ gustiness [Z T-1 ~> m s-1] - real, intent(in) :: UStar_Mean !< ustar w/o gustiness [Z T-1 ~> m s-1] + real, intent(in) :: UStar !< ustar including gustiness [Z T-1 ~> m s-1] real, intent(in) :: Abs_Coriolis !< absolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: BLD !< boundary layer depth [Z ~> m] @@ -1927,12 +1996,13 @@ subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] or other units + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] + !! or other units real, optional, intent(in) :: m_to_MLD_units !< A conversion factor from meters - !! to the desired units for MLD, sometimes [m Z-1 ~> 1] + !! to the desired units for MLD, sometimes [Z m-1 ~> 1] ! Local variables real :: scale ! A dimensional rescaling factor, often [nondim] or [m Z-1 ~> 1] - integer :: i,j + integer :: i, j scale = 1.0 ; if (present(m_to_MLD_units)) scale = US%Z_to_m * m_to_MLD_units @@ -2151,7 +2221,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "EPBL_MLD_TOLERANCE", CS%MLD_tol, & "The tolerance for the iteratively determined mixed "//& "layer depth. This is only used with USE_MLD_ITERATION.", & - units="meter", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%Use_MLD_iteration) + units="meter", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%Use_MLD_iteration) call get_param(param_file, mdl, "EPBL_MLD_BISECTION", CS%MLD_bisection, & "If true, use bisection with the iterative determination of the self-consistent "//& "mixed layer depth. Otherwise use the false position after a maximum and minimum "//& @@ -2312,7 +2382,7 @@ 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) + CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%dZ_subroundoff) call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min, & "The (tiny) minimum friction velocity used within the "//& "ePBL code, derived from OMEGA and ANGSTROM.", & From 2337404b8fde641d9e6e8f8d030f57572551bd4e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Aug 2023 17:13:09 -0400 Subject: [PATCH 091/146] +SpV_avg optional argument to extract_optics_slice Added the optional argument SpV_avg to extract_optics_slice for use along with an appropriate value for opacity_scale to convert the units of opacity from [Z-1] to [H-1] in non-Boussinesq mode without making use of the Boussinesq reference density. All Boussinesq answers are bitwise identical, but non-Boussinesq answers will change and become less dependent on the Boussinesq reference density when this new argument is used. There is a new optional argument to a publicly visible subroutine. --- .../vertical/MOM_opacity.F90 | 40 +++++++++++++------ 1 file changed, 27 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index c48308a912..bd1b804cba 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -451,7 +451,7 @@ function opacity_manizza(chl_data) !> This subroutine returns a 2-d slice at constant j of fields from an optics_type, with the potential !! for rescaling these fields. -subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_top, penSW_scale) +subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_top, penSW_scale, SpV_avg) type(optics_type), intent(in) :: optics !< An optics structure that has values of opacities !! and shortwave fluxes. integer, intent(in) :: j !< j-index to extract @@ -459,33 +459,47 @@ subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_ type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(max(optics%nbands,1),SZI_(G),SZK_(GV)), & optional, intent(out) :: opacity !< The opacity in each band, i-point, and layer [Z-1 ~> m-1], - !! but with units that can be altered by opacity_scale. + !! but with units that can be altered by opacity_scale + !! and the presence of SpV_avg to change this to other + !! units like [H-1 ~> m-1 or m2 kg-1] real, optional, intent(in) :: opacity_scale !< A factor by which to rescale the opacity [nondim] or !! [Z H-1 ~> 1 or m3 kg-1] real, dimension(max(optics%nbands,1),SZI_(G)), & optional, intent(out) :: penSW_top !< The shortwave radiation [Q R Z T-1 ~> W m-2] !! at the surface in each of the nbands bands !! that penetrates beyond the surface skin layer. - real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux [nondim]? + real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux [nondim] + !! or other units. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: SpV_avg !< The layer-averaged specific volume [R-1 ~> m3 kg-1] + !! that is used along with opacity_scale in non-Boussinesq + !! cases to change the opacity from distance based units to + !! mass-based units ! Local variables - real :: scale_opacity, scale_penSW ! Rescaling factors [nondim]? + real :: scale_opacity ! A rescaling factor for opacity [nondim], or the same units as opacity_scale. + real :: scale_penSW ! A rescaling factor for the penetrating shortwave radiation [nondim] or the + ! same units as penSW_scale integer :: i, is, ie, k, nz, n is = G%isc ; ie = G%iec ; nz = GV%ke scale_opacity = 1.0 ; if (present(opacity_scale)) scale_opacity = opacity_scale scale_penSW = 1.0 ; if (present(penSW_scale)) scale_penSW = penSW_scale - if (present(opacity)) then ; do k=1,nz ; do i=is,ie - do n=1,optics%nbands - opacity(n,i,k) = scale_opacity * optics%opacity_band(n,i,j,k) - enddo - enddo ; enddo ; endif + if (present(opacity)) then + if (present(SpV_avg)) then + do k=1,nz ; do i=is,ie ; do n=1,optics%nbands + opacity(n,i,k) = (scale_opacity * SpV_avg(i,j,k)) * optics%opacity_band(n,i,j,k) + enddo ; enddo ; enddo + else + do k=1,nz ; do i=is,ie ; do n=1,optics%nbands + opacity(n,i,k) = scale_opacity * optics%opacity_band(n,i,j,k) + enddo ; enddo ; enddo + endif + endif - if (present(penSW_top)) then ; do k=1,nz ; do i=is,ie - do n=1,optics%nbands - penSW_top(n,i) = scale_penSW * optics%sw_pen_band(n,i,j) - enddo + if (present(penSW_top)) then ; do i=is,ie ; do n=1,optics%nbands + penSW_top(n,i) = scale_penSW * optics%sw_pen_band(n,i,j) enddo ; enddo ; endif end subroutine extract_optics_slice From 2f1bdc06d41e35582759c678de2a48ba1fd66fd9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Aug 2023 17:17:46 -0400 Subject: [PATCH 092/146] +*Non-Boussinesq bulk mixed layer calculations This commit includes a series of distinct changes that enable the use of the bulk mixed layer code in non-Boussinesq mode, including an option to do the non-Boussinesq energetic calculations even when the model itself is in Boussinesq or semi-Boussinesq mode. When in fully non-Boussinesq mode, there is no longer any dependence on the Boussinesq reference density. Rescaled the units of turbulent kinetic energy in the bulk mixed layer code to [H L2 T-2 ~> m3 s-2 or J m-2] to reduce the influence of the Boussinesq reference density in non-Boussinesq configurations, with similar changes to the internal units of diagnostics and energy sources. Also revised how Hmix_min is set in bulkmixedlayer_init to avoid any dependency on the Boussinesq reference density. Add a U_star argument to find_starting_TKE and use find_ustar to set it. In some places a thickness-based definition of U_star is used. Also added logic to the code setting the starting TKE and k_Ustar so that they supports a greater range of valid combinations of available input variables. Added the option of using non-Boussinesq energetic calculations in the bulk mixed layer code, which avoids any dependence on the Boussinesq reference density, but do the calculations with the approximation that specific volume is conserved during mixing, thereby ignoring certain weak thermobaric effects. The use of this new option is controlled by the new runtime parameter BML_NONBOUSSINESQ, which is false by default except in fully non-Boussinesq mode. All of the new code is wrapped in logical branches that are selected by the new logical variable CS%nonBous_energetics in the bulk mixed layer control structure. This option changes which equation of state routines are called by the bulk mixed layer module. When in non-Boussinesq mode, use forces%tau_mag and tv%SpV_avg instead of forces%ustar and GV%Rho0 to determine the surface TKE flux. Use SpV_avg to rescale opacity in non-Boussinesq mode via the use of an optional argument to extract_optics_slice Use a call to average_specific_vol to translate the mass of the mixed layer into the mixed layer thickness. As a part of these changes, there is extensive but systematic revision to the code. Within the bulkmixedlayer_CS type the units of 10 elements (mostly diagnostics) are changed, and there is one new logical element. There are 17 new arguments to internal subroutines in the bulk mixed layer module, while the units of another 11 are changed. There are 35 new or renamed internal variables, while the units of another 28 internal variables are changed. A total of 23 thickness conversion factors were eliminated, and the remaining references to the Boussinesq reference density are only used in Boussinesq mode. Apart from the new runtime parameter, the external interfaces are unchanged. By default, answers are bitwise identical for Boussinesq or semi-Boussinesq configurations, but there is a new entry (BML_NONBOUSINESQ) in some MOM_parameter_doc files, and answers do change in non-Boussinesq mode and become independent of the value of RHO_0. --- .../vertical/MOM_bulk_mixed_layer.F90 | 1339 ++++++++++++----- 1 file changed, 958 insertions(+), 381 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index ceba8dad1a..c7e522eddc 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -3,10 +3,13 @@ module MOM_bulk_mixed_layer ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : time_type, diag_ctrl, diag_update_remap_grids use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : average_specific_vol, calculate_density_derivs +use MOM_EOS, only : calculate_spec_vol, calculate_specific_vol_derivs use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : extractFluxes1d, forcing, find_ustar @@ -15,7 +18,6 @@ module MOM_bulk_mixed_layer use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain implicit none ; private @@ -53,7 +55,7 @@ module MOM_bulk_mixed_layer real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-2]. real :: mech_TKE_floor !< A tiny floor on the amount of turbulent kinetic energy that is !! used when the mixed layer does not yet contain HMIX_MIN fluid - !! [Z L2 T-2 ~> m3 s-2]. The default is so small that its actual + !! [H L2 T-2 ~> m3 s-2 or J m-2]. The default is so small that its actual !! value is irrelevant, but it is detectably greater than 0. real :: H_limit_fluxes !< When the total ocean depth is less than this !! value [H ~> m or kg m-2], scale away all surface forcing to @@ -95,6 +97,8 @@ module MOM_bulk_mixed_layer !! shortwave radiation is absorbed is corrected by !! moving some of the heating upward in the water !! column. The default is false. + logical :: nonBous_energetics !< If true, use non-Boussinesq expressions for the energetic + !! calculations used in the bulk mixed layer calculations. logical :: Resolve_Ekman !< If true, the nkml layers in the mixed layer are !! chosen to optimally represent the impact of the !! Ekman transport on the mixed layer TKE budget. @@ -102,7 +106,7 @@ module MOM_bulk_mixed_layer logical :: TKE_diagnostics = .false. !< If true, calculate extensive diagnostics of the TKE budget logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff !! at the river mouths to rivermix_depth - real :: rivermix_depth = 0.0 !< The depth of mixing if do_rivermix is true [Z ~> m]. + real :: rivermix_depth = 0.0 !< The depth of mixing if do_rivermix is true [H ~> m or kg m-2]. logical :: limit_det !< If true, limit the extent of buffer layer !! detrainment to be consistent with neighbors. real :: lim_det_dH_sfc !< The fractional limit in the change between grid @@ -125,17 +129,17 @@ module MOM_bulk_mixed_layer real :: Allowed_S_chg !< The amount by which salinity is allowed !! to exceed previous values during detrainment [S ~> ppt] - ! These are terms in the mixed layer TKE budget, all in [Z L2 T-3 ~> m3 s-3] except as noted. + ! These are terms in the mixed layer TKE budget, all in [H L2 T-3 ~> m3 s-3 or W m-2] except as noted. real, allocatable, dimension(:,:) :: & ML_depth, & !< The mixed layer depth [H ~> m or kg m-2]. - diag_TKE_wind, & !< The wind source of TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_RiBulk, & !< The resolved KE source of TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_conv, & !< The convective source of TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating [Z L2 T-3 ~> m3 s-3]. - diag_TKE_mech_decay, & !< The decay of mechanical TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_conv_decay, & !< The decay of convective TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [Z L2 T-3 ~> m3 s-3]. - diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2 [Z L2 T-3 ~> m3 s-3]. + diag_TKE_wind, & !< The wind source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_RiBulk, & !< The resolved KE source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv, & !< The convective source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_mech_decay, & !< The decay of mechanical TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv_decay, & !< The decay of convective TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2 [H L2 T-3 ~> m3 s-3 or W m-2]. diag_PE_detrain, & !< The spurious source of potential energy due to mixed layer !! detrainment [R Z L2 T-3 ~> W m-2]. diag_PE_detrain2 !< The spurious source of potential energy due to mixed layer only @@ -191,7 +195,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C type(optics_type), pointer :: optics !< The structure that can be queried for the !! inverse of the vertical absorption decay !! scale for penetrating shortwave radiation. - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m]. + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and !! outgoing surface freshwater fluxes are !! combined before being applied, instead of @@ -219,6 +223,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C T, & ! The layer temperatures [C ~> degC]. S, & ! The layer salinities [S ~> ppt]. R0, & ! The potential density referenced to the surface [R ~> kg m-3]. + SpV0, & ! The specific volume referenced to the surface [R-1 ~> m3 kg-1]. Rcv ! The coordinate variable potential density [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)) :: & u, & ! The zonal velocity [L T-1 ~> m s-1]. @@ -236,17 +241,22 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C real, dimension(SZI_(G),SZJ_(G)) :: & h_miss ! The summed absolute mismatch [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - U_star_2d ! The wind friction velocity, calculated using the Boussinesq reference density or + U_star_2d, &! The wind friction velocity, calculated using the Boussinesq reference density or ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] + U_star_H_2d ! The wind friction velocity in thickness-based units, calculated + ! using the Boussinesq reference density or the time-evolving + ! surface density in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G)) :: & TKE, & ! The turbulent kinetic energy available for mixing over a - ! time step [Z L2 T-2 ~> m3 s-2]. + ! time step [H L2 T-2 ~> m3 s-2 or J m-2]. Conv_En, & ! The turbulent kinetic energy source due to mixing down to - ! the depth of free convection [Z L2 T-2 ~> m3 s-2]. + ! the depth of free convection [H L2 T-2 ~> m3 s-2 or J m-2]. htot, & ! The total depth of the layers being considered for ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. + SpV0_tot, & ! The integrated specific volume referenced to the surface + ! of the layers which are fully entrained [H R-1 ~> m4 kg-1 or m]. Rcv_tot, & ! The integrated coordinate value potential density of the ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully @@ -271,14 +281,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. dR0_dT, & ! Partial derivative of the mixed layer potential density with ! temperature [R C-1 ~> kg m-3 degC-1]. + dSpV0_dT, & ! Partial derivative of the mixed layer specific volume with + ! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. dRcv_dT, & ! Partial derivative of the coordinate variable potential ! density in the mixed layer with temperature [R C-1 ~> kg m-3 degC-1]. dR0_dS, & ! Partial derivative of the mixed layer potential density with ! salinity [R S-1 ~> kg m-3 ppt-1]. + dSpV0_dS, & ! Partial derivative of the mixed layer specific volume with + ! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. dRcv_dS, & ! Partial derivative of the coordinate variable potential ! density in the mixed layer with salinity [R S-1 ~> kg m-3 ppt-1]. + p_sfc, & ! The sea surface pressure [R L2 T-2 ~> Pa] + dp_ml, & ! The pressure change across the mixed layer [R L2 T-2 ~> Pa] + SpV_ml, & ! The specific volume averaged across the mixed layer [R-1 ~> m3 kg-1] TKE_river ! The source of turbulent kinetic energy available for mixing - ! at rivermouths [Z L2 T-3 ~> m3 s-3]. + ! at rivermouths [H L2 T-3 ~> m3 s-3 or W m-2]. real, dimension(max(CS%nsw,1),SZI_(G)) :: & Pen_SW_bnd ! The penetrating fraction of the shortwave heating integrated @@ -294,16 +311,17 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. real :: RmixConst ! A combination of constants used in the river mixing energy - ! calculation [L2 T-2 R-2 ~> m8 s-2 kg-2] + ! calculation [H L2 Z-1 T-2 R-2 ~> m8 s-2 kg-2 or m5 s-2 kg-1] or + ! [H L2 Z-1 T-2 ~> m2 s-2 or kg m-1 s-2] real, dimension(SZI_(G)) :: & dKE_FC, & ! The change in mean kinetic energy due to free convection - ! [Z L2 T-2 ~> m3 s-2]. + ! [H L2 T-2 ~> m3 s-2 or J m-2]. h_CA ! The depth to which convective adjustment has gone [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)) :: & dKE_CA, & ! The change in mean kinetic energy due to convective - ! adjustment [Z L2 T-2 ~> m3 s-2]. + ! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. cTKE ! The turbulent kinetic energy source due to convective - ! adjustment [Z L2 T-2 ~> m3 s-2]. + ! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)) :: & Hsfc_max, & ! The thickness of the surface region (mixed and buffer layers) ! after entrainment but before any buffer layer detrainment [H ~> m or kg m-2]. @@ -322,8 +340,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C real :: dHsfc, dHD ! Local copies of nondimensional parameters [nondim] real :: H_nbr ! A minimum thickness based on neighboring thicknesses [H ~> m or kg m-2]. - real :: absf_x_H ! The absolute value of f times the mixed layer thickness [Z T-1 ~> m s-1]. - real :: kU_star ! Ustar times the Von Karman constant [Z T-1 ~> m s-1]. + real :: absf_x_H ! The absolute value of f times the mixed layer thickness [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: kU_star ! Ustar times the Von Karman constant [H T-1 ~> m s-1 or kg m-2 s-1]. real :: dt__diag ! A rescaled copy of dt_diag (if present) or dt [T ~> s]. logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. @@ -340,8 +358,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & "MOM_mixed_layer: Temperature, salinity and an equation of state "//& "must now be used.") - if (.NOT. associated(fluxes%ustar)) call MOM_error(FATAL, & - "MOM_mixed_layer: No surface TKE fluxes (ustar) defined in mixedlayer!") + if (.not. (associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "MOM_mixed_layer: No surface TKE fluxes (ustar or tau_mag) defined in mixedlayer!") nkmb = CS%nkml+CS%nkbl Inkml = 1.0 / REAL(CS%nkml) @@ -417,12 +435,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Extract the friction velocity from the forcing type. call find_ustar(fluxes, tv, U_star_2d, G, GV, US) + if (CS%Resolve_Ekman .and. (CS%nkml>1)) & + call find_ustar(fluxes, tv, U_star_H_2d, G, GV, US, H_T_units=.true.) !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & - !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,Rcv,ksort, & - !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,htot,Ttot,Stot,TKE,Conv_en, & + !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,SpV0,Rcv,ksort, & + !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,dSpV0_dT,dSpV0_dS,htot,Ttot,Stot,TKE,Conv_en, & !$OMP RmixConst,TKE_river,Pen_SW_bnd,netMassInOut,NetMassOut, & - !$OMP Net_heat,Net_salt,uhtot,vhtot,R0_tot,Rcv_tot,dKE_FC, & + !$OMP Net_heat,Net_salt,uhtot,vhtot,R0_tot,Rcv_tot,SpV0_tot,dKE_FC, & !$OMP Idecay_len_TKE,cMKE,Hsfc,dHsfc,dHD,H_nbr,kU_Star, & !$OMP absf_x_H,ebml,eaml) !$OMP do @@ -434,7 +454,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C eps(i,k) = 0.0 ; if (k > nkmb) eps(i,k) = GV%Angstrom_H T(i,k) = tv%T(i,j,k) ; S(i,k) = tv%S(i,j,k) enddo ; enddo - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_Z) + if (nsw>0) then + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_Z) + else + call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_RZ, & + SpV_avg=tv%SpV_avg) + endif + endif do k=1,nz ; do i=is,ie d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 @@ -449,26 +476,35 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C do k=1,CS%nkml ; do i=is,ie p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) enddo ; enddo - call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, EOSdom) + if (CS%nonBous_energetics) then + call calculate_specific_vol_derivs(T(:,1), S(:,1), p_ref, dSpV0_dT, dSpV0_dS, tv%eqn_of_state, EOSdom) + do k=1,nz + call calculate_spec_vol(T(:,k), S(:,k), p_ref, SpV0(:,k), tv%eqn_of_state, EOSdom) + enddo + else + call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, EOSdom) + do k=1,nz + call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, EOSdom) + enddo + endif call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, EOSdom) do k=1,nz - call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, EOSdom) call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo if (CS%ML_resort) then if (CS%ML_presort_nz_conv_adj > 0) & - call convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, & + call convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, & US, CS, CS%ML_presort_nz_conv_adj) - call sort_ML(h, R0, eps, G, GV, CS, ksort) + call sort_ML(h, R0, SpV0, eps, G, GV, CS, ksort) else do k=1,nz ; do i=is,ie ; ksort(i,k) = k ; enddo ; enddo ! Undergo instantaneous entrainment into the buffer layers and mixed layers ! to remove hydrostatic instabilities. Any water that is lighter than ! currently in the mixed or buffer layer is entrained. - call convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, US, CS) + call convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, US, CS) do i=is,ie ; h_CA(i) = h(i,1) ; enddo endif @@ -478,18 +514,26 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Here we add an additional source of TKE to the mixed layer where river ! is present to simulate unresolved estuaries. The TKE input is diagnosed ! as follows: - ! TKE_river[Z L2 T-3 ~> m3 s-3] = 0.5*rivermix_depth * g * Irho0**2 * drho_ds * + ! TKE_river[H L2 T-3 ~> m3 s-3] = 0.5*rivermix_depth * g * Irho0**2 * drho_ds * ! River*(Samb - Sriver) = CS%mstar*U_star^3 ! where River is in units of [R Z T-1 ~> kg m-2 s-1]. ! Samb = Ambient salinity at the mouth of the estuary ! rivermix_depth = The prescribed depth over which to mix river inflow ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) - RmixConst = 0.5*CS%rivermix_depth * GV%g_Earth * Irho0**2 - do i=is,ie - TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) - enddo + if (CS%nonBous_energetics) then + RmixConst = -0.5*CS%rivermix_depth * GV%g_Earth + do i=is,ie + TKE_river(i) = max(0.0, RmixConst * dSpV0_dS(i) * & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + enddo + else + RmixConst = 0.5*CS%rivermix_depth * GV%g_Earth * Irho0**2 + do i=is,ie + TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + enddo + endif else do i=is,ie ; TKE_river(i) = 0.0 ; enddo endif @@ -507,8 +551,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C tv, aggregate_FW_forcing) ! This subroutine causes the mixed layer to entrain to depth of free convection. - call mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, R0_tot, Rcv_tot, & - u, v, T, S, R0, Rcv, eps, dR0_dT, dRcv_dT, dR0_dS, dRcv_dS, & + call mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, R0_tot, SpV0_tot, Rcv_tot, & + u, v, T, S, R0, SpV0, Rcv, eps, dR0_dT, dSpV0_dT, dRcv_dT, dR0_dS, dSpV0_dS, dRcv_dS, & netMassInOut, netMassOut, Net_heat, Net_salt, & nsw, Pen_SW_bnd, opacity_band, Conv_En, dKE_FC, & j, ksort, G, GV, US, CS, tv, fluxes, dt, aggregate_FW_forcing) @@ -520,14 +564,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! First the TKE at the depth of free convection that is available ! to drive mixing is calculated. call find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & - TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & + TKE, TKE_river, Idecay_len_TKE, cMKE, tv, dt, Idt_diag, & j, ksort, G, GV, US, CS) ! Here the mechanically driven entrainment occurs. call mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & - R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, dR0_dT, dRcv_dT, & - cMKE, Idt_diag, nsw, Pen_SW_bnd, opacity_band, TKE, & - Idecay_len_TKE, j, ksort, G, GV, US, CS) + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, cMKE, Idt_diag, nsw, Pen_SW_bnd, & + opacity_band, TKE, Idecay_len_TKE, j, ksort, G, GV, US, CS) call absorbRemainingSW(G, GV, US, h(:,1:), opacity_band, nsw, optics, j, dt, & CS%H_limit_fluxes, CS%correct_absorption, CS%absorb_all_SW, & @@ -540,19 +584,46 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Calculate the homogeneous mixed layer properties and store them in layer 0. do i=is,ie ; if (htot(i) > 0.0) then Ih = 1.0 / htot(i) - R0(i,0) = R0_tot(i) * Ih ; Rcv(i,0) = Rcv_tot(i) * Ih + if (CS%nonBous_energetics) then + SpV0(i,0) = SpV0_tot(i) * Ih + else + R0(i,0) = R0_tot(i) * Ih + endif + Rcv(i,0) = Rcv_tot(i) * Ih T(i,0) = Ttot(i) * Ih ; S(i,0) = Stot(i) * Ih h(i,0) = htot(i) else ! This may not ever be needed? - T(i,0) = T(i,1) ; S(i,0) = S(i,1) ; R0(i,0) = R0(i,1) ; Rcv(i,0) = Rcv(i,1) + T(i,0) = T(i,1) ; S(i,0) = S(i,1) ; Rcv(i,0) = Rcv(i,1) + if (CS%nonBous_energetics) then + SpV0(i,0) = SpV0(i,1) + else + R0(i,0) = R0(i,1) + endif h(i,0) = htot(i) endif ; enddo if (write_diags .and. allocated(CS%ML_depth)) then ; do i=is,ie CS%ML_depth(i,j) = h(i,0) ! Store the diagnostic. enddo ; endif - if (associated(Hml)) then ; do i=is,ie - Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_Z) ! Rescale the diagnostic for output. - enddo ; endif + + if (associated(Hml)) then + ! Return the mixed layerd depth in [Z ~> m]. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is,ie + Hml(i,j) = G%mask2dT(i,j) * GV%H_to_Z*h(i,0) + enddo + else + do i=is,ie ; dp_ml(i) = GV%g_Earth * GV%H_to_RZ * h(i,0) ; enddo + if (associated(tv%p_surf)) then + do i=is,ie ; p_sfc(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_sfc(i) = 0.0 ; enddo + endif + call average_specific_vol(T(:,0), S(:,0), p_sfc, dp_ml, SpV_ml, tv%eqn_of_state) + do i=is,ie + Hml(i,j) = G%mask2dT(i,j) * GV%H_to_RZ * SpV_ml(i) * h(i,0) + enddo + endif + endif ! At this point, return water to the original layers, but constrained to ! still be sorted. After this point, all the water that is in massive @@ -565,8 +636,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! these unused layers (but not currently in the code). if (CS%ML_resort) then - call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), GV%Rlay(:), eps, & - d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) + call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), GV%Rlay(:), eps, & + d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS) endif if (CS%limit_det .or. (CS%id_Hsfc_max > 0) .or. (CS%id_Hsfc_min > 0)) then @@ -598,13 +669,13 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! from the buffer layer into the interior. These steps might best be ! treated in conjunction. if (CS%nkbl == 1) then - call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & + call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), & GV%Rlay(:), dt, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & dRcv_dT, dRcv_dS, max_BL_det) elseif (CS%nkbl == 2) then - call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & + call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), & GV%Rlay(:), dt, dt__diag, d_ea, j, G, GV, US, CS, & - dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS, max_BL_det) else ! CS%nkbl not = 1 or 2 ! This code only works with 1 or 2 buffer layers. call MOM_error(FATAL, "MOM_mixed_layer: CS%nkbl must be 1 or 2 for now.") @@ -628,14 +699,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! as the third piece will then optimally describe mixed layer ! restratification. For nkml>=4 the whole strategy should be revisited. do i=is,ie - kU_star = CS%vonKar*fluxes%ustar(i,j) ! Maybe could be replaced with u*+w*? - if (associated(fluxes%ustar_shelf) .and. & - associated(fluxes%frac_shelf_h)) then - if (fluxes%frac_shelf_h(i,j) > 0.0) & - kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & - fluxes%frac_shelf_h(i,j) * (CS%vonKar*fluxes%ustar_shelf(i,j)) + ! Perhaps in the following, u* could be replaced with u*+w*? + kU_star = CS%vonKar * U_star_H_2d(i,j) + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then + if (fluxes%frac_shelf_h(i,j) > 0.0) then + if (allocated(tv%SpV_avg)) then + kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & + fluxes%frac_shelf_h(i,j) * ((CS%vonKar*fluxes%ustar_shelf(i,j)) / & + (GV%H_to_RZ * tv%SpV_avg(i,j,1))) + else + kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & + fluxes%frac_shelf_h(i,j) * (CS%vonKar*GV%Z_to_H*fluxes%ustar_shelf(i,j)) + endif + endif endif - absf_x_H = 0.25 * GV%H_to_Z * h(i,0) * & + absf_x_H = 0.25 * h(i,0) * & ((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) ! If the mixed layer vertical viscosity specification is changed in @@ -756,7 +834,7 @@ end subroutine bulkmixedlayer !> This subroutine does instantaneous convective entrainment into the buffer !! layers and mixed layers to remove hydrostatic instabilities. Any water that !! is lighter than currently in the mixed- or buffer- layer is entrained. -subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & +subroutine convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, & dKE_CA, cTKE, j, G, GV, US, CS, nz_conv) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -768,6 +846,8 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & !! points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [C ~> degC]. @@ -780,10 +860,10 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & !! a layer. real, dimension(SZI_(G),SZK_(GV)), intent(out) :: dKE_CA !< The vertically integrated change in !! kinetic energy due to convective - !! adjustment [Z L2 T-2 ~> m3 s-2]. + !! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(out) :: cTKE !< The buoyant turbulent kinetic energy !! source due to convective adjustment - !! [Z L2 T-2 ~> m3 s-2]. + !! [H L2 T-2 ~> m3 s-2 or J m-2]. integer, intent(in) :: j !< The j-index to work on. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure @@ -795,6 +875,8 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & real, dimension(SZI_(G)) :: & R0_tot, & ! The integrated potential density referenced to the surface ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. + SpV0_tot, & ! The integrated specific volume referenced to the surface + ! of the layers which are fully entrained [H R-1 ~> m4 kg-1 or m]. Rcv_tot, & ! The integrated coordinate value potential density of the ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully @@ -808,13 +890,14 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & h_orig_k1 ! The depth of layer k1 before convective adjustment [H ~> m or kg m-2]. real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. - real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of + real :: g_H_2Rho0 ! Half the gravitational acceleration times ! the conversion from H to Z divided by the mean density, - ! in [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! in [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + logical :: unstable integer :: is, ie, nz, i, k, k1, nzc, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) nzc = nz ; if (present(nz_conv)) nzc = nz_conv nkmb = CS%nkml+CS%nkbl @@ -826,7 +909,11 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & h_orig_k1(i) = h(i,k1) KE_orig(i) = 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2) uhtot(i) = h(i,k1)*u(i,k1) ; vhtot(i) = h(i,k1)*v(i,k1) - R0_tot(i) = R0(i,k1) * h(i,k1) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0(i,k1) * h(i,k1) + else + R0_tot(i) = R0(i,k1) * h(i,k1) + endif cTKE(i,k1) = 0.0 ; dKE_CA(i,k1) = 0.0 Rcv_tot(i) = Rcv(i,k1) * h(i,k1) @@ -834,15 +921,28 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & enddo do k=k1+1,nzc do i=is,ie - if ((h(i,k) > eps(i,k)) .and. (R0_tot(i) > h(i,k1)*R0(i,k))) then + if (CS%nonBous_energetics) then + unstable = (SpV0_tot(i) < h(i,k1)*SpV0(i,k)) + else + unstable = (R0_tot(i) > h(i,k1)*R0(i,k)) + endif + if ((h(i,k) > eps(i,k)) .and. unstable) then h_ent = h(i,k)-eps(i,k) - cTKE(i,k1) = cTKE(i,k1) + h_ent * g_H2_2Rho0 * & - (R0_tot(i) - h(i,k1)*R0(i,k)) * CS%nstar2 + if (CS%nonBous_energetics) then + ! This and the other energy calculations assume that specific volume is + ! conserved during mixing, which ignores certain thermobaric contributions. + cTKE(i,k1) = cTKE(i,k1) + 0.5 * h_ent * (GV%g_Earth * GV%H_to_RZ) * & + (h(i,k1)*SpV0(i,k) - SpV0_tot(i)) * CS%nstar2 + SpV0_tot(i) = SpV0_tot(i) + h_ent * SpV0(i,k) + else + cTKE(i,k1) = cTKE(i,k1) + h_ent * g_H_2Rho0 * & + (R0_tot(i) - h(i,k1)*R0(i,k)) * CS%nstar2 + R0_tot(i) = R0_tot(i) + h_ent * R0(i,k) + endif if (k < nkmb) then cTKE(i,k1) = cTKE(i,k1) + cTKE(i,k) dKE_CA(i,k1) = dKE_CA(i,k1) + dKE_CA(i,k) endif - R0_tot(i) = R0_tot(i) + h_ent * R0(i,k) KE_orig(i) = KE_orig(i) + 0.5*h_ent* & (u(i,k)*u(i,k) + v(i,k)*v(i,k)) uhtot(i) = uhtot(i) + h_ent*u(i,k) @@ -862,10 +962,14 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! layer in question, if it has entrained. do i=is,ie ; if (h(i,k1) > h_orig_k1(i)) then Ih = 1.0 / h(i,k1) - R0(i,k1) = R0_tot(i) * Ih + if (CS%nonBous_energetics) then + SpV0(i,k1) = SpV0_tot(i) * Ih + else + R0(i,k1) = R0_tot(i) * Ih + endif u(i,k1) = uhtot(i) * Ih ; v(i,k1) = vhtot(i) * Ih - dKE_CA(i,k1) = dKE_CA(i,k1) + GV%H_to_Z * (CS%bulk_Ri_convective * & - (KE_orig(i) - 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2))) + dKE_CA(i,k1) = dKE_CA(i,k1) + CS%bulk_Ri_convective * & + (KE_orig(i) - 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2)) Rcv(i,k1) = Rcv_tot(i) * Ih T(i,k1) = Ttot(i) * Ih ; S(i,k1) = Stot(i) * Ih endif ; enddo @@ -873,7 +977,11 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! If lower mixed or buffer layers are massless, give them the properties of the ! layer above. do k=2,min(nzc,nkmb) ; do i=is,ie ; if (h(i,k) == 0.0) then - R0(i,k) = R0(i,k-1) + if (CS%nonBous_energetics) then + SpV0(i,k) = SpV0(i,k-1) + else + R0(i,k) = R0(i,k-1) + endif Rcv(i,k) = Rcv(i,k-1) ; T(i,k) = T(i,k-1) ; S(i,k) = S(i,k-1) endif ; enddo ; enddo @@ -883,8 +991,8 @@ end subroutine convective_adjustment !! convection. The depth of free convection is the shallowest depth at which the !! fluid is denser than the average of the fluid above. subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & - R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, & - dR0_dT, dRcv_dT, dR0_dS, dRcv_dS, & + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, dR0_dS, dSpV0_dS, dRcv_dS, & netMassInOut, netMassOut, Net_heat, Net_salt, & nsw, Pen_SW_bnd, opacity_band, Conv_En, & dKE_FC, j, ksort, G, GV, US, CS, tv, fluxes, dt, & @@ -909,6 +1017,8 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(out) :: R0_tot !< The integrated mixed layer potential density referenced !! to 0 pressure [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G)), intent(out) :: SpV0_tot !< The integrated mixed layer specific volume referenced + !! to 0 pressure [H R-1 ~> m4 kg-1 or m]. real, dimension(SZI_(G)), intent(out) :: Rcv_tot !< The integrated mixed layer coordinate !! variable potential density [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G),SZK_(GV)), & @@ -922,6 +1032,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. @@ -930,10 +1043,14 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect to + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to !! temperature [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of R0 with respect to !! salinity [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of SpV0 with respect to + !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of Rcv with respect to !! salinity [R S-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: netMassInOut !< The net mass flux (if non-Boussinesq) @@ -954,9 +1071,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(max(nsw,1),SZI_(G),SZK_(GV)), intent(in) :: opacity_band !< The opacity in each band of !! penetrating shortwave radiation [H-1 ~> m-1 or m2 kg-1]. real, dimension(SZI_(G)), intent(out) :: Conv_En !< The buoyant turbulent kinetic energy source - !! due to free convection [Z L2 T-2 ~> m3 s-2]. + !! due to free convection [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(out) :: dKE_FC !< The vertically integrated change in kinetic - !! energy due to free convection [Z L2 T-2 ~> m3 s-2]. + !! energy due to free convection [H L2 T-2 ~> m3 s-2 or J m-2]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & intent(in) :: ksort !< The density-sorted k-indices. @@ -992,7 +1109,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real :: T_precip ! The temperature of the precipitation [C ~> degC]. real :: C1_3, C1_6 ! 1/3 and 1/6 [nondim] real :: En_fn, Frac, x1 ! Nondimensional temporary variables [nondim]. - real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. + real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5] or [R-1 H ~> m4 kg-1 or m]. real :: dr_ent, dr_comp ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. real :: dr_dh ! The partial derivative of dr_ent with h_ent [R ~> kg m-3]. real :: h_min, h_max ! The minimum and maximum estimates for h_ent [H ~> m or kg m-2] @@ -1000,9 +1117,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real :: h_evap ! The thickness that is evaporated [H ~> m or kg m-2]. real :: dh_Newt ! The Newton's method estimate of the change in ! h_ent between iterations [H ~> m or kg m-2]. - real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of + real :: g_H_2Rho0 ! Half the gravitational acceleration times ! the conversion from H to Z divided by the mean density, - ! [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. real :: opacity ! The opacity converted to inverse thickness units [H-1 ~> m-1 or m2 kg-1] real :: sum_Pen_En ! The potential energy change due to penetrating @@ -1016,7 +1133,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Angstrom = GV%Angstrom_H C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) Idt = 1.0 / dt is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1060,10 +1177,17 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Stot(i) = h_ent*S(i,k) + Net_salt(i) uhtot(i) = u(i,1)*netMassIn(i) + u(i,k)*h_ent vhtot(i) = v(i,1)*netMassIn(i) + v(i,k)*h_ent - R0_tot(i) = (h_ent*R0(i,k) + netMassIn(i)*R0(i,1)) + & + if (CS%nonBous_energetics) then + SpV0_tot(i) = (h_ent*SpV0(i,k) + netMassIn(i)*SpV0(i,1)) + & +! dSpV0_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & + (dSpV0_dT(i)*(Net_heat(i) + Pen_absorbed) - & + dSpV0_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) + else + R0_tot(i) = (h_ent*R0(i,k) + netMassIn(i)*R0(i,1)) + & ! dR0_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & (dR0_dT(i)*(Net_heat(i) + Pen_absorbed) - & dR0_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) + endif Rcv_tot(i) = (h_ent*Rcv(i,k) + netMassIn(i)*Rcv(i,1)) + & ! dRcv_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & (dRcv_dT(i)*(Net_heat(i) + Pen_absorbed) - & @@ -1075,7 +1199,8 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T_precip * netMassIn(i) * GV%H_to_RZ else ! This is a massless column, but zero out the summed variables anyway for safety. - htot(i) = 0.0 ; Ttot(i) = 0.0 ; Stot(i) = 0.0 ; R0_tot(i) = 0.0 ; Rcv_tot = 0.0 + htot(i) = 0.0 ; Ttot(i) = 0.0 ; Stot(i) = 0.0 ; Rcv_tot = 0.0 + R0_tot(i) = 0.0 ; SpV0_tot(i) = 0.0 uhtot(i) = 0.0 ; vhtot(i) = 0.0 ; Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 endif ; enddo @@ -1093,7 +1218,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent - R0_tot(i) = R0_tot(i) + h_ent*R0(i,k) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + h_ent*SpV0(i,k) + else + R0_tot(i) = R0_tot(i) + h_ent*R0(i,k) + endif uhtot(i) = uhtot(i) + h_ent*u(i,k) vhtot(i) = vhtot(i) + h_ent*v(i,k) @@ -1117,7 +1246,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif Stot(i) = Stot(i) + h_evap*S(i,k) - R0_tot(i) = R0_tot(i) + dR0_dS(i)*h_evap*S(i,k) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + dSpV0_dS(i)*h_evap*S(i,k) + else + R0_tot(i) = R0_tot(i) + dR0_dS(i)*h_evap*S(i,k) + endif Rcv_tot(i) = Rcv_tot(i) + dRcv_dS(i)*h_evap*S(i,k) d_eb(i,k) = d_eb(i,k) - h_evap @@ -1136,14 +1269,25 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! The following section calculates how much fluid will be entrained. h_avail = h(i,k) - eps(i,k) if (h_avail > 0.0) then - dr = R0_tot(i) - htot(i)*R0(i,k) h_ent = 0.0 - dr0 = dr - do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then - dr0 = dr0 - (dR0_dT(i)*Pen_SW_bnd(n,i)) * & - opacity_band(n,i,k)*htot(i) - endif ; enddo + if (CS%nonBous_energetics) then + dr = htot(i)*SpV0(i,k) - SpV0_tot(i) + + dr0 = dr + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + dr0 = dr0 + (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * & + opacity_band(n,i,k)*htot(i) + endif ; enddo + else + dr = R0_tot(i) - htot(i)*R0(i,k) + + dr0 = dr + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + dr0 = dr0 - (dR0_dT(i)*Pen_SW_bnd(n,i)) * & + opacity_band(n,i,k)*htot(i) + endif ; enddo + endif ! Some entrainment will occur from this layer. if (dr0 > 0.0) then @@ -1153,8 +1297,13 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! density averaged over the mixed layer and that layer. opacity = opacity_band(n,i,k) SW_trans = exp(-h_avail*opacity) - dr_comp = dr_comp + (dR0_dT(i)*Pen_SW_bnd(n,i)) * & - ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + if (CS%nonBous_energetics) then + dr_comp = dr_comp - (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * & + ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + else + dr_comp = dr_comp + (dR0_dT(i)*Pen_SW_bnd(n,i)) * & + ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + endif endif ; enddo if (dr_comp >= 0.0) then ! The entire layer is entrained. @@ -1171,7 +1320,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_min = 0.0 ; h_max = h_avail do n=1,nsw - r_SW_top(n) = dR0_dT(i) * Pen_SW_bnd(n,i) + if (CS%nonBous_energetics) then + r_SW_top(n) = -dSpV0_dT(i) * Pen_SW_bnd(n,i) + else + r_SW_top(n) = dR0_dT(i) * Pen_SW_bnd(n,i) + endif C2(n) = r_SW_top(n) * opacity_band(n,i,k)**2 enddo do itt=1,10 @@ -1218,27 +1371,40 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & En_fn = ((opacity*htot(i) + 2.0) * & ((1.0-SW_trans) / x1) - 1.0 + SW_trans) endif - sum_Pen_En = sum_Pen_En - (dR0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + if (CS%nonBous_energetics) then + sum_Pen_En = sum_Pen_En + (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + else + sum_Pen_En = sum_Pen_En - (dR0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + endif Pen_absorbed = Pen_absorbed + Pen_SW_bnd(n,i) * (1.0 - SW_trans) Pen_SW_bnd(n,i) = Pen_SW_bnd(n,i) * SW_trans endif ; enddo - Conv_En(i) = Conv_En(i) + g_H2_2Rho0 * h_ent * & - ( (R0_tot(i) - R0(i,k)*htot(i)) + sum_Pen_En ) + if (CS%nonBous_energetics) then + ! This and the other energy calculations assume that specific volume is + ! conserved during mixing, which ignores certain thermobaric contributions. + Conv_En(i) = Conv_En(i) + 0.5 * (GV%g_Earth * GV%H_to_RZ) * h_ent * & + ( (SpV0(i,k)*htot(i) - SpV0_tot(i)) + sum_Pen_En ) + SpV0_tot(i) = SpV0_tot(i) + (h_ent * SpV0(i,k) + Pen_absorbed*dSpV0_dT(i)) + else + Conv_En(i) = Conv_En(i) + g_H_2Rho0 * h_ent * & + ( (R0_tot(i) - R0(i,k)*htot(i)) + sum_Pen_En ) + R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + endif - R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) Stot(i) = Stot(i) + h_ent * S(i,k) Ttot(i) = Ttot(i) + (h_ent * T(i,k) + Pen_absorbed) Rcv_tot(i) = Rcv_tot(i) + (h_ent * Rcv(i,k) + Pen_absorbed*dRcv_dT(i)) endif ! dr0 > 0.0 - if (h_ent > 0.0) then - if (htot(i) > 0.0) & + + if ((h_ent > 0.0) .and. (htot(i) > 0.0)) & dKE_FC(i) = dKE_FC(i) + CS%bulk_Ri_convective * 0.5 * & - ((GV%H_to_Z*h_ent) / (htot(i)*(h_ent+htot(i)))) * & + ((h_ent) / (htot(i)*(h_ent+htot(i)))) * & ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) + if (h_ent > 0.0) then htot(i) = htot(i) + h_ent h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent @@ -1249,7 +1415,6 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif endif - endif ! h_avail>0 endif ; enddo ! i loop enddo ! k loop @@ -1259,7 +1424,7 @@ end subroutine mixedlayer_convection !> This subroutine determines the TKE available at the depth of free !! convection to drive mechanical entrainment. subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & - TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & + TKE, TKE_river, Idecay_len_TKE, cMKE, tv, dt, Idt_diag, & j, ksort, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1276,28 +1441,30 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F !! the time-evolving surface density in !! non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(G)), intent(inout) :: Conv_En !< The buoyant turbulent kinetic energy source - !! due to free convection [Z L2 T-2 ~> m3 s-2]. + !! due to free convection [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: dKE_FC !< The vertically integrated change in !! kinetic energy due to free convection - !! [Z L2 T-2 ~> m3 s-2]. + !! [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: cTKE !< The buoyant turbulent kinetic energy !! source due to convective adjustment - !! [Z L2 T-2 ~> m3 s-2]. + !! [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: dKE_CA !< The vertically integrated change in !! kinetic energy due to convective - !! adjustment [Z L2 T-2 ~> m3 s-2]. + !! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(out) :: TKE !< The turbulent kinetic energy available for - !! mixing over a time step [Z L2 T-2 ~> m3 s-2]. + !! mixing over a time step [H L2 T-2 ~> m3 s-2 or J m-2] real, dimension(SZI_(G)), intent(out) :: Idecay_len_TKE !< The inverse of the vertical decay !! scale for TKE [H-1 ~> m-1 or m2 kg-1]. real, dimension(SZI_(G)), intent(in) :: TKE_river !< The source of turbulent kinetic energy !! available for driving mixing at river mouths - !! [Z L2 T-3 ~> m3 s-3]. + !! [H L2 T-3 ~> m3 s-3 or W m-2]. real, dimension(2,SZI_(G)), intent(out) :: cMKE !< Coefficients of HpE and HpE^2 in !! calculating the denominator of MKE_rate, !! [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. real, intent(in) :: dt !< The time step [T ~> s]. real, intent(in) :: Idt_diag !< The inverse of the accumulated diagnostic !! time interval [T-1 ~> s-1]. @@ -1310,24 +1477,26 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F ! convection to drive mechanical entrainment. ! Local variables - real :: dKE_conv ! The change in mean kinetic energy due to all convection [Z L2 T-2 ~> m3 s-2]. + real :: dKE_conv ! The change in mean kinetic energy due to all convection [H L2 T-2 ~> m3 s-2 or J m-2]. real :: nstar_FC ! The effective efficiency with which the energy released by ! free convection is converted to TKE, often ~0.2 [nondim]. real :: nstar_CA ! The effective efficiency with which the energy released by ! convective adjustment is converted to TKE, often ~0.2 [nondim]. real :: TKE_CA ! The potential energy released by convective adjustment if - ! that release is positive [Z L2 T-2 ~> m3 s-2]. + ! that release is positive [H L2 T-2 ~> m3 s-2 or J m-2]. real :: MKE_rate_CA ! MKE_rate for convective adjustment [nondim], 0 to 1. real :: MKE_rate_FC ! MKE_rate for free convection [nondim], 0 to 1. - real :: totEn_Z ! The total potential energy released by convection, [Z3 T-2 ~> m3 s-2]. + real :: totEn_Z ! The total potential energy released by convection, [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. real :: absf ! The absolute value of f averaged to thickness points [T-1 ~> s-1]. real :: U_star ! The friction velocity [Z T-1 ~> m s-1]. - real :: absf_Ustar ! The absolute value of f divided by U_star [Z-1 ~> m-1]. - real :: wind_TKE_src ! The surface wind source of TKE [Z L2 T-3 ~> m3 s-3]. + real :: absf_Ustar ! The absolute value of f divided by U_star converted to thickness units [H-1 ~> m-1 or m2 kg-1] + real :: wind_TKE_src ! The surface wind source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. real :: diag_wt ! The ratio of the current timestep to the diagnostic ! timestep (which may include 2 calls) [nondim]. + real :: H_to_Z ! The thickness to depth conversion factor, which in non-Boussinesq mode is + ! based on the layer-averaged specific volume [Z H-1 ~> nondim or m3 kg-1] integer :: is, ie, nz, i is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1337,6 +1506,12 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F do i=is,ie U_star = U_star_2d(i,j) + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + H_to_Z = GV%H_to_Z + else + H_to_Z = GV%H_to_RZ * tv%SpV_avg(i,j,1) + endif + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then if (fluxes%frac_shelf_h(i,j) > 0.0) & U_star = (1.0 - fluxes%frac_shelf_h(i,j)) * U_star + & @@ -1344,14 +1519,15 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F endif if (U_star < CS%ustar_min) U_star = CS%ustar_min + if (CS%omega_frac < 1.0) then absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif - absf_Ustar = absf / U_star - Idecay_len_TKE(i) = (absf_Ustar * CS%TKE_decay) * GV%H_to_Z + absf_Ustar = H_to_Z * absf / U_star + Idecay_len_TKE(i) = absf_Ustar * CS%TKE_decay ! The first number in the denominator could be anywhere up to 16. The ! value of 3 was chosen to minimize the time-step dependence of the amount @@ -1362,9 +1538,9 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F ! This equation assumes that small & large scales contribute to mixed layer ! deepening at similar rates, even though small scales are dissipated more ! rapidly (implying they are less efficient). -! Ih = 1.0/(16.0*CS%vonKar*U_star*dt) - Ih = GV%H_to_Z/(3.0*CS%vonKar*U_star*dt) - cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = (absf_Ustar*GV%H_to_Z) * Ih +! Ih = H_to_Z / (16.0*CS%vonKar*U_star*dt) + Ih = H_to_Z / (3.0*CS%vonKar*U_star*dt) + cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = absf_Ustar * Ih if (Idecay_len_TKE(i) > 0.0) then exp_kh = exp(-htot(i)*Idecay_len_TKE(i)) @@ -1382,7 +1558,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F if (totEn_Z > 0.0) then nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (H_to_Z**2*(absf*htot(i))**3) * totEn_Z)) else nstar_FC = CS%nstar endif @@ -1392,7 +1568,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F if (Conv_En(i) > 0.0) then totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA * (htot(i) / h_CA(i)) ) nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (H_to_Z**2*(absf*htot(i))**3) * totEn_Z)) else nstar_FC = CS%nstar endif @@ -1400,7 +1576,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA) if (TKE_CA > 0.0) then nstar_CA = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt * (absf*(h_CA(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (H_to_Z**2*(absf*h_CA(i))**3) * totEn_Z)) else nstar_CA = CS%nstar endif @@ -1422,15 +1598,25 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F dKE_conv = dKE_CA(i,1) * MKE_rate_CA + dKE_FC(i) * MKE_rate_FC ! At this point, it is assumed that cTKE is positive and stored in TKE_CA! ! Note: Removed factor of 2 in u*^3 terms. - TKE(i) = (dt*CS%mstar)*((US%Z_to_L**2*(U_star*U_Star*U_Star))*exp_kh) + & - (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then + TKE(i) = (dt*CS%mstar)*((GV%Z_to_H*US%Z_to_L**2*(U_star*U_Star*U_Star))*exp_kh) + & + (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + else + ! Note that GV%Z_to_H*US%Z_to_L**2*U_star**3 = GV%RZ_to_H * US%Z_to_L*fluxes%tau_mag(i,j) * U_star + TKE(i) = (dt*CS%mstar) * ((GV%RZ_to_H*US%Z_to_L * fluxes%tau_mag(i,j) * U_star)*exp_kh) + & + (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + endif if (CS%do_rivermix) then ! Add additional TKE at river mouths TKE(i) = TKE(i) + TKE_river(i)*dt*exp_kh endif if (CS%TKE_diagnostics) then - wind_TKE_src = CS%mstar*(US%Z_to_L**2*U_star*U_Star*U_Star) * diag_wt + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then + wind_TKE_src = CS%mstar*(GV%Z_to_H*US%Z_to_L**2*U_star*U_Star*U_Star) * diag_wt + else + wind_TKE_src = CS%mstar*(GV%RZ_to_H * US%Z_to_L*fluxes%tau_mag(i,j) * U_star) * diag_wt + endif CS%diag_TKE_wind(i,j) = CS%diag_TKE_wind(i,j) + & ( wind_TKE_src + TKE_river(i) * diag_wt ) CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + dKE_conv*Idt_diag @@ -1449,8 +1635,8 @@ end subroutine find_starting_TKE !> This subroutine calculates mechanically driven entrainment. subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & - R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, & - dR0_dT, dRcv_dT, cMKE, Idt_diag, nsw, & + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, cMKE, Idt_diag, nsw, & Pen_SW_bnd, opacity_band, TKE, & Idecay_len_TKE, j, ksort, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1473,6 +1659,8 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(inout) :: R0_tot !< The integrated mixed layer potential density !! referenced to 0 pressure [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G)), intent(inout) :: SpV0_tot !< The integrated mixed layer specific volume referenced + !! to 0 pressure [H R-1 ~> m4 kg-1 or m]. real, dimension(SZI_(G)), intent(inout) :: Rcv_tot !< The integrated mixed layer coordinate variable !! potential density [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G),SZK_(GV)), & @@ -1486,6 +1674,9 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. @@ -1494,6 +1685,8 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect to + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to !! temperature [R C-1 ~> kg m-3 degC-1]. real, dimension(2,SZI_(G)), intent(in) :: cMKE !< Coefficients of HpE and HpE^2 used in calculating the @@ -1510,7 +1703,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! penetrating shortwave radiation [H-1 ~> m-1 or m2 kg-1]. real, dimension(SZI_(G)), intent(inout) :: TKE !< The turbulent kinetic energy !! available for mixing over a time - !! step [Z L2 T-2 ~> m3 s-2]. + !! step [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(inout) :: Idecay_len_TKE !< The vertical TKE decay rate [H-1 ~> m-1 or m2 kg-1]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & @@ -1537,18 +1730,18 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! conversion from H to m divided by the mean density, ! in [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: TKE_full_ent ! The TKE remaining if a layer is fully entrained - ! [Z L2 T-2 ~> m3 s-2]. + ! [H L2 T-2 ~> m3 s-2 or J m-2]. real :: dRL ! Work required to mix water from the next layer ! across the mixed layer [L2 T-2 ~> m2 s-2]. real :: Pen_En_Contrib ! Penetrating SW contributions to the changes in ! TKE, divided by layer thickness in m [L2 T-2 ~> m2 s-2]. real :: Cpen1 ! A temporary variable [L2 T-2 ~> m2 s-2]. real :: dMKE ! A temporary variable related to the release of mean - ! kinetic energy [H Z L2 T-2 ~> m4 s-2 or kg m s-2] - real :: TKE_ent ! The TKE that remains if h_ent were entrained [Z L2 T-2 ~> m3 s-2]. + ! kinetic energy [H2 L2 T-2 ~> m4 s-2 or kg2 m-2 s-2] + real :: TKE_ent ! The TKE that remains if h_ent were entrained [H L2 T-2 ~> m3 s-2 or J m-2] real :: TKE_ent1 ! The TKE that would remain, without considering the - ! release of mean kinetic energy [Z L2 T-2 ~> m3 s-2]. - real :: dTKE_dh ! The partial derivative of TKE with h_ent [Z L2 T-2 H-1 ~> m2 s-2 or m5 s-2 kg-1]. + ! release of mean kinetic energy [H L2 T-2 ~> m3 s-2 or J m-2] + real :: dTKE_dh ! The partial derivative of TKE with h_ent [L2 T-2 ~> m2 s-2] real :: Pen_dTKE_dh_Contrib ! The penetrating shortwave contribution to ! dTKE_dh [L2 T-2 ~> m2 s-2]. real :: EF4_val ! The result of EF4() (see later) [H-1 ~> m-1 or m2 kg-1]. @@ -1581,8 +1774,12 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_avail = h(i,k) - eps(i,k) if ((h_avail > 0.) .and. ((TKE(i) > 0.) .or. (htot(i) < Hmix_min))) then - dRL = g_H_2Rho0 * (R0(i,k)*htot(i) - R0_tot(i) ) - dMKE = (GV%H_to_Z * CS%bulk_Ri_ML) * 0.5 * & + if (CS%nonBous_energetics) then + dRL = 0.5 * (GV%g_Earth * GV%H_to_RZ) * (SpV0_tot(i) - SpV0(i,k)*htot(i)) + else + dRL = g_H_2Rho0 * (R0(i,k)*htot(i) - R0_tot(i) ) + endif + dMKE = CS%bulk_Ri_ML * 0.5 * & ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) ! Find the TKE that would remain if the entire layer were entrained. @@ -1621,14 +1818,19 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Pen_En1 = exp_kh * ((1.0+opacity*htot(i))*f1_x1 + & opacity*h_avail*f2_x1) endif - Pen_En_Contrib = Pen_En_Contrib + & - (g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + if (CS%nonBous_energetics) then + Pen_En_Contrib = Pen_En_Contrib - & + (0.5 * (GV%g_Earth * GV%H_to_RZ) * dSpV0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + else + Pen_En_Contrib = Pen_En_Contrib + & + (g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + endif endif ; enddo HpE = htot(i)+h_avail MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) EF4_val = EF4(htot(i)+h_neglect,h_avail,Idecay_len_TKE(i)) - TKE_full_ent = (exp_kh*TKE(i) - (h_avail*GV%H_to_Z)*(dRL*f1_kh + Pen_En_Contrib)) + & + TKE_full_ent = (exp_kh*TKE(i) - h_avail*(dRL*f1_kh + Pen_En_Contrib)) + & MKE_rate*dMKE*EF4_val if ((TKE_full_ent >= 0.0) .or. (h_avail+htot(i) <= Hmix_min)) then ! The layer will be fully entrained. @@ -1637,12 +1839,11 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & if (CS%TKE_diagnostics) then E_HxHpE = h_ent / ((htot(i)+h_neglect)*(htot(i)+h_ent+h_neglect)) CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & - Idt_diag * ((exp_kh-1.0)* TKE(i) + (h_ent*GV%H_to_Z)*dRL*(1.0-f1_kh) + & + Idt_diag * ((exp_kh-1.0)* TKE(i) + h_ent*dRL*(1.0-f1_kh) + & MKE_rate*dMKE*(EF4_val-E_HxHpE)) - CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - & - Idt_diag*(GV%H_to_Z*h_ent)*dRL + CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - Idt_diag*h_ent*dRL CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - & - Idt_diag*(GV%H_to_Z*h_ent)*Pen_En_Contrib + Idt_diag*h_ent*Pen_En_Contrib CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + & Idt_diag*MKE_rate*dMKE*E_HxHpE endif @@ -1702,21 +1903,25 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Pen_En1 = exp_kh * ((1.0+opacity*htot(i))*f1_x1 + & opacity*h_ent*f2_x1) endif - Cpen1 = g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i) + if (CS%nonBous_energetics) then + Cpen1 = -0.5 * (GV%g_Earth * GV%H_to_RZ) * dSpV0_dT(i) * Pen_SW_bnd(n,i) + else + Cpen1 = g_H_2Rho0 * dR0_dT(i) * Pen_SW_bnd(n,i) + endif Pen_En_Contrib = Pen_En_Contrib + Cpen1*(Pen_En1 - f1_kh) Pen_dTKE_dh_Contrib = Pen_dTKE_dh_Contrib + & Cpen1*((1.0-SW_trans) - opacity*(htot(i) + h_ent)*SW_trans) endif ; enddo ! (Pen_SW_bnd(n,i) > 0.0) - TKE_ent1 = exp_kh* TKE(i) - (h_ent*GV%H_to_Z)*(dRL*f1_kh + Pen_En_Contrib) + TKE_ent1 = exp_kh* TKE(i) - h_ent*(dRL*f1_kh + Pen_En_Contrib) EF4_val = EF4(htot(i)+h_neglect,h_ent,Idecay_len_TKE(i),dEF4_dh) HpE = htot(i)+h_ent MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) TKE_ent = TKE_ent1 + dMKE*EF4_val*MKE_rate ! TKE_ent is the TKE that would remain if h_ent were entrained. - dTKE_dh = ((-Idecay_len_TKE(i)*TKE_ent1 - dRL*GV%H_to_Z) + & - Pen_dTKE_dh_Contrib*GV%H_to_Z) + dMKE * MKE_rate* & + dTKE_dh = ((-Idecay_len_TKE(i)*TKE_ent1 - dRL) + & + Pen_dTKE_dh_Contrib) + dMKE * MKE_rate* & (dEF4_dh - EF4_val*MKE_rate*(cMKE(1,i)+2.0*cMKE(2,i)*HpE)) ! dh_Newt = -TKE_ent / dTKE_dh ! Bisect if the Newton's method prediction is outside of the bounded range. @@ -1750,14 +1955,11 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & E_HxHpE = h_ent / ((htot(i)+h_neglect)*(HpE+h_neglect)) CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & - Idt_diag * ((exp_kh-1.0)* TKE(i) + (h_ent*GV%H_to_Z)*dRL*(1.0-f1_kh) + & + Idt_diag * ((exp_kh-1.0)* TKE(i) + h_ent*dRL*(1.0-f1_kh) + & dMKE*MKE_rate*(EF4_val-E_HxHpE)) - CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - & - Idt_diag*(h_ent*GV%H_to_Z)*dRL - CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - & - Idt_diag*(h_ent*GV%H_to_Z)*Pen_En_Contrib - CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + & - Idt_diag*dMKE*MKE_rate*E_HxHpE + CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - Idt_diag*h_ent*dRL + CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - Idt_diag*h_ent*Pen_En_Contrib + CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + Idt_diag*dMKE*MKE_rate*E_HxHpE endif TKE(i) = 0.0 @@ -1771,7 +1973,11 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif ; enddo htot(i) = htot(i) + h_ent - R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + (h_ent * SpV0(i,k) + Pen_absorbed*dSpV0_dT(i)) + else + R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + endif h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent @@ -1790,12 +1996,14 @@ end subroutine mechanical_entrainment !> This subroutine generates an array of indices that are sorted by layer !! density. -subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) +subroutine sort_ML(h, R0, SpV0, eps, G, GV, CS, ksort) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: R0 !< The potential density used to sort !! the layers [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The (small) thickness that must !! remain in each layer [H ~> m or kg m-2]. type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure @@ -1803,6 +2011,7 @@ subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) ! Local variables real :: R0sort(SZI_(G),SZK_(GV)) ! The sorted potential density [R ~> kg m-3] + real :: SpV0sort(SZI_(G),SZK_(GV)) ! The sorted specific volume [R-1 ~> m3 kg-1] integer :: nsort(SZI_(G)) ! The number of layers left to sort logical :: done_sorting(SZI_(G)) integer :: i, k, ks, is, ie, nz, nkmb @@ -1821,27 +2030,44 @@ subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) do k=1,nz ; do i=is,ie ; ksort(i,k) = -1 ; enddo ; enddo do i=is,ie ; nsort(i) = 0 ; done_sorting(i) = .false. ; enddo - do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then - if (done_sorting(i)) then ; ks = nsort(i) ; else - do ks=nsort(i),1,-1 - if (R0(i,k) >= R0sort(i,ks)) exit - R0sort(i,ks+1) = R0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) - enddo - if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. - endif - ksort(i,ks+1) = k - R0sort(i,ks+1) = R0(i,k) - nsort(i) = nsort(i) + 1 - endif ; enddo ; enddo + if (CS%nonBous_energetics) then + do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then + if (done_sorting(i)) then ; ks = nsort(i) ; else + do ks=nsort(i),1,-1 + if (SpV0(i,k) <= SpV0sort(i,ks)) exit + SpV0sort(i,ks+1) = SpV0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) + enddo + if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. + endif + + ksort(i,ks+1) = k + SpV0sort(i,ks+1) = SpV0(i,k) + nsort(i) = nsort(i) + 1 + endif ; enddo ; enddo + else + do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then + if (done_sorting(i)) then ; ks = nsort(i) ; else + do ks=nsort(i),1,-1 + if (R0(i,k) >= R0sort(i,ks)) exit + R0sort(i,ks+1) = R0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) + enddo + if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. + endif + + ksort(i,ks+1) = k + R0sort(i,ks+1) = R0(i,k) + nsort(i) = nsort(i) + 1 + endif ; enddo ; enddo + endif end subroutine sort_ML !> This subroutine actually moves properties between layers to achieve a !! resorted state, with all of the resorted water either moved into the correct !! interior layers or in the top nkmb layers. -subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS, & - dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) +subroutine resort_ML(h, T, S, R0, SpV0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS, & + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. @@ -1851,6 +2077,8 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining !! potential density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each @@ -1876,6 +2104,10 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS !! potential density referenced !! to the surface with salinity, !! [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect + !! to temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of SpV0 with respect + !! to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential !! density with potential @@ -1914,15 +2146,18 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS real :: S_up, S_dn ! Salinities projected to match the target densities of two layers [S ~> ppt] real :: R0_up, R0_dn ! Potential densities projected to match the target coordinate ! densities of two layers [R ~> kg m-3] + real :: SpV0_up, SpV0_dn ! Specific volumes projected to be consistent with the target coordinate + ! densities of two layers [R-1 ~> m3 kg-1] real :: I_hup, I_hdn ! Inverse of the new thicknesses of the two layers [H-1 ~> m-1 or m2 kg-1] real :: h_to_up, h_to_dn ! Thickness transferred to two layers [H ~> m or kg m-2] real :: wt_dn ! Fraction of the thickness transferred to the deeper layer [nondim] real :: dR1, dR2 ! Density difference with the target densities of two layers [R ~> kg m-3] - real :: dPE, min_dPE ! Values proportional to the potential energy change due to the merging - ! of a pair of layers [R H2 ~> kg m-1 or kg3 m-6] + real :: dPE, min_dPE ! Values proportional to the potential energy change due to the merging of a + ! pair of layers [R H2 ~> kg m-1 or kg3 m-7] or [R-1 H2 ~> m5 kg-1 or kg m-1] real :: hmin, min_hmin ! The thickness of the thinnest layer [H ~> m or kg m-2] real :: h_tmp(SZK_(GV)) ! A copy of the original layer thicknesses [H ~> m or kg m-2] real :: R0_tmp(SZK_(GV)) ! A copy of the original layer potential densities [R ~> kg m-3] + real :: SpV0_tmp(SZK_(GV)) ! A copy of the original layer specific volumes [R ~> kg m-3] real :: T_tmp(SZK_(GV)) ! A copy of the original layer temperatures [C ~> degC] real :: S_tmp(SZK_(GV)) ! A copy of the original layer salinities [S ~> ppt] real :: Rcv_tmp(SZK_(GV)) ! A copy of the original layer coordinate densities [R ~> kg m-3] @@ -2024,13 +2259,19 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS T_dn = T(i,k) + dT_dR * dR2 S_dn = S(i,k) + dS_dR * dR2 - R0_up = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR1 - R0_dn = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR2 + if (CS%nonBous_energetics) then + SpV0_up = SpV0(i,k) + (dT_dR*dSpV0_dT(i) + dS_dR*dSpV0_dS(i)) * dR1 + SpV0_dn = SpV0(i,k) + (dT_dR*dSpV0_dT(i) + dS_dR*dSpV0_dS(i)) * dR2 + + ! Make sure the new properties are acceptable, and avoid creating obviously unstable profiles. + if ((SpV0_up < SpV0(i,0)) .or. (SpV0_dn < SpV0(i,0))) exit + else + R0_up = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR1 + R0_dn = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR2 - ! Make sure the new properties are acceptable. - if ((R0_up > R0(i,0)) .or. (R0_dn > R0(i,0))) & - ! Avoid creating obviously unstable profiles. - exit + ! Make sure the new properties are acceptable, and avoid creating obviously unstable profiles. + if ((R0_up > R0(i,0)) .or. (R0_dn > R0(i,0))) exit + endif wt_dn = (Rcv(i,k) - RcvTgt(k2-1)) / (RcvTgt(k2) - RcvTgt(k2-1)) h_to_up = (h(i,k)-eps(i,k)) * (1.0 - wt_dn) @@ -2038,8 +2279,13 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS I_hup = 1.0 / (h(i,k2-1) + h_to_up) I_hdn = 1.0 / (h(i,k2) + h_to_dn) - R0(i,k2-1) = (R0(i,k2)*h(i,k2-1) + R0_up*h_to_up) * I_hup - R0(i,k2) = (R0(i,k2)*h(i,k2) + R0_dn*h_to_dn) * I_hdn + if (CS%nonBous_energetics) then + SpV0(i,k2-1) = (SpV0(i,k2)*h(i,k2-1) + SpV0_up*h_to_up) * I_hup + SpV0(i,k2) = (SpV0(i,k2)*h(i,k2) + SpV0_dn*h_to_dn) * I_hdn + else + R0(i,k2-1) = (R0(i,k2)*h(i,k2-1) + R0_up*h_to_up) * I_hup + R0(i,k2) = (R0(i,k2)*h(i,k2) + R0_dn*h_to_dn) * I_hdn + endif T(i,k2-1) = (T(i,k2)*h(i,k2-1) + T_up*h_to_up) * I_hup T(i,k2) = (T(i,k2)*h(i,k2) + T_dn*h_to_dn) * I_hdn @@ -2083,7 +2329,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ks_min = -1 ; min_dPE = 1.0 ; min_hmin = 0.0 do ks=1,nks-1 k1 = ks2(ks) ; k2 = ks2(ks+1) - dPE = max(0.0, (R0(i,k2)-R0(i,k1)) * h(i,k1) * h(i,k2)) + if (CS%nonBous_energetics) then + dPE = max(0.0, (SpV0(i,k1) - SpV0(i,k2)) * (h(i,k1) * h(i,k2))) + else + dPE = max(0.0, (R0(i,k2) - R0(i,k1)) * h(i,k1) * h(i,k2)) + endif hmin = min(h(i,k1)-eps(i,k1), h(i,k2)-eps(i,k2)) if ((ks_min < 0) .or. (dPE < min_dPE) .or. & ((dPE <= 0.0) .and. (hmin < min_hmin))) then @@ -2101,7 +2351,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS h(i,k_src) = eps(i,k_src) h(i,k_tgt) = h(i,k_tgt) + h_move I_hnew = 1.0 / (h(i,k_tgt)) - R0(i,k_tgt) = (R0(i,k_tgt)*h_tgt_old + R0(i,k_src)*h_move) * I_hnew + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = (SpV0(i,k_tgt)*h_tgt_old + SpV0(i,k_src)*h_move) * I_hnew + else + R0(i,k_tgt) = (R0(i,k_tgt)*h_tgt_old + R0(i,k_src)*h_move) * I_hnew + endif T(i,k_tgt) = (T(i,k_tgt)*h_tgt_old + T(i,k_src)*h_move) * I_hnew S(i,k_tgt) = (S(i,k_tgt)*h_tgt_old + S(i,k_src)*h_move) * I_hnew @@ -2127,7 +2381,12 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ! Save all the properties of the nkmb layers that might be replaced. do k=1,nkmb - h_tmp(k) = h(i,k) ; R0_tmp(k) = R0(i,k) + h_tmp(k) = h(i,k) + if (CS%nonBous_energetics) then + SpV0_tmp(k) = SpV0(i,k) + else + R0_tmp(k) = R0(i,k) + endif T_tmp(k) = T(i,k) ; S_tmp(k) = S(i,k) ; Rcv_tmp(k) = Rcv(i,k) h(i,k) = 0.0 @@ -2145,7 +2404,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS h_move = h(i,k_src)-eps(i,k_src) h(i,k_src) = eps(i,k_src) h(i,k_tgt) = h_move - R0(i,k_tgt) = R0(i,k_src) + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = SpV0(i,k_src) + else + R0(i,k_tgt) = R0(i,k_src) + endif T(i,k_tgt) = T(i,k_src) ; S(i,k_tgt) = S(i,k_src) Rcv(i,k_tgt) = Rcv(i,k_src) @@ -2154,7 +2417,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS d_eb(i,k_tgt) = d_eb(i,k_tgt) + h_move else h(i,k_tgt) = h_tmp(k_src) - R0(i,k_tgt) = R0_tmp(k_src) + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = SpV0_tmp(k_src) + else + R0(i,k_tgt) = R0_tmp(k_src) + endif T(i,k_tgt) = T_tmp(k_src) ; S(i,k_tgt) = S_tmp(k_src) Rcv(i,k_tgt) = Rcv_tmp(k_src) @@ -2177,8 +2444,8 @@ end subroutine resort_ML !> This subroutine moves any water left in the former mixed layers into the !! two buffer layers and may also move buffer layer water into the interior !! isopycnal layers. -subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, G, GV, US, CS, & - dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) +subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, G, GV, US, CS, & + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS, max_BL_det) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -2187,6 +2454,8 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each @@ -2208,6 +2477,12 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, !! potential density referenced to the !! surface with salinity !! [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of specific + !! volume with respect to temeprature + !! [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of specific + !! volume with respect to salinity + !! [R-1 S-1 ~> m3 kg-1 ppt-1] real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential density !! with potential temperature, @@ -2228,6 +2503,8 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! layers [H ~> m or kg m-2]. real :: R0_to_bl ! The depth integrated amount of R0 that is detrained to the ! buffer layer [H R ~> kg m-2 or kg2 m-5] + real :: SpV0_to_bl ! The depth integrated amount of SpV0 that is detrained to the + ! buffer layer [H R-1 ~> m4 kg-1 or m] real :: Rcv_to_bl ! The depth integrated amount of Rcv that is detrained to the ! buffer layer [H R ~> kg m-2 or kg2 m-5] real :: T_to_bl ! The depth integrated amount of T that is detrained to the @@ -2246,27 +2523,36 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: stays_min, stays_max ! The minimum and maximum permitted values of ! stays [H ~> m or kg m-2]. + logical :: intermediate ! True if the water in layer kb1 is intermediate in density + ! between the water in kb2 and the water being detrained. logical :: mergeable_bl ! If true, it is an option to combine the two ! buffer layers and create water that matches ! the target density of an interior layer. + logical :: better_to_merge ! True if it is energetically favorable to merge layers real :: stays_merge ! If the two buffer layers can be combined ! stays_merge is the thickness of the upper ! layer that remains [H ~> m or kg m-2]. real :: stays_min_merge ! The minimum allowed value of stays_merge [H ~> m or kg m-2]. real :: dR0_2dz, dRcv_2dz ! Half the vertical gradients of R0 and Rcv [R H-1 ~> kg m-4 or m-1] + real :: dSpV0_2dz ! Half the vertical gradients of SpV0 and Rcv [R-1 H-1 ~> m2 kg-1 or m5 kg-2] ! real :: dT_2dz ! Half the vertical gradient of T [C H-1 ~> degC m-1 or degC m2 kg-1] ! real :: dS_2dz ! Half the vertical gradient of S [S H-1 ~> ppt m-1 or ppt m2 kg-1] real :: scale_slope ! A nondimensional number < 1 used to scale down ! the slope within the upper buffer layer when ! water MUST be detrained to the lower layer [nondim]. - real :: dPE_extrap ! The potential energy change due to dispersive + real :: dPE_extrap_rhoG ! The potential energy change due to dispersive ! advection or mixing layers, divided by ! rho_0*g [H2 ~> m2 or kg2 m-4]. + real :: dPE_extrapolate ! The potential energy change due to dispersive advection or + ! mixing layers [R Z L2 T-2 ~> J m-2]. real :: dPE_det, dPE_merge ! The energy required to mix the detrained water ! into the buffer layer or the merge the two ! buffer layers [R H2 L2 Z-1 T-2 ~> J m-2 or J kg2 m-8]. + real :: dPE_det_nB, dPE_merge_nB ! The energy required to mix the detrained water + ! into the buffer layer or the merge the two + ! buffer layers [R Z L2 T-2 ~> J m-2]. real :: h_from_ml ! The amount of additional water that must be ! drawn from the mixed layer [H ~> m or kg m-2]. @@ -2284,8 +2570,11 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: h2_to_k1, h2_to_k1_rem ! Fluxes of lower buffer layer water to the interior layer that ! is just denser than the lower buffer layer [H ~> m or kg m-2]. - real :: R0_det, T_det, S_det ! Detrained values of R0 [R ~> kg m-3], T [C ~> degC] and S [S ~> ppt] + real :: R0_det ! Detrained value of potential density referenced to the surface [R ~> kg m-3] + real :: SpV0_det ! Detrained value of specific volume referenced to the surface [R-1 ~> m3 kg-1] + real :: T_det, S_det ! Detrained values of temperature [C ~> degC] and salinity [S ~> ppt] real :: Rcv_stays, R0_stays ! Values of Rcv and R0 that stay in a layer [R ~> kg m-3] + real :: SpV0_stays ! Values of SpV0 that stay in a layer [R-1 ~> m3 kg-1] real :: T_stays, S_stays ! Values of T and S that stay in a layer, [C ~> degC] and S [S ~> ppt] real :: dSpice_det, dSpice_stays! The spiciness difference between an original ! buffer layer and the water that moves into @@ -2296,7 +2585,11 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! moves into an interior layer [R ~> kg m-3]. real :: dSpice_2dz ! The vertical gradient of spiciness used for ! advection [R H-1 ~> kg m-4 or m-1]. - + real :: dSpiceSpV_stays ! The specific volume based spiciness difference between an original + ! buffer layer and the water that stays in that layer [R-1 ~> m3 kg-1] + real :: dSpiceSpV_lim ! A limit on the specific volume based spiciness difference + ! between the lower buffer layer and the water that + ! moves into an interior layer [R-1 ~> m3 kg-1] real :: dPE_ratio ! Multiplier of dPE_det at which merging is ! permitted - here (detrainment_per_day/dt)*30 ! days? [nondim] @@ -2306,11 +2599,12 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: dT_dS_gauge, dS_dT_gauge ! The relative scales of temperature and ! salinity changes in defining spiciness, in ! [C S-1 ~> degC ppt-1] and [S C-1 ~> ppt degC-1]. - real :: I_denom ! A work variable with units of [S2 R-2 ~> ppt2 m6 kg-2]. + real :: I_denom ! A work variable with units of [S2 R-2 ~> ppt2 m6 kg-2] or [R2 S2 ~> ppt2 kg2 m-6]. real :: g_2 ! 1/2 g_Earth [L2 Z-1 T-2 ~> m s-2]. real :: Rho0xG ! Rho0 times G_Earth [R L2 Z-1 T-2 ~> kg m-2 s-2]. real :: I2Rho0 ! 1 / (2 Rho0) [R-1 ~> m3 kg-1]. + real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. real :: Idt_H2 ! The square of the conversion from thickness to Z ! divided by the time step [Z2 H-2 T-1 ~> s-1 or m6 kg-2 s-1]. logical :: stable_Rcv ! If true, the buffer layers are stable with @@ -2326,22 +2620,25 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: Ihk0, Ihk1, Ih12 ! Assorted inverse thickness work variables [H-1 ~> m-1 or m2 kg-1] real :: dR1, dR2, dR2b, dRk1 ! Assorted density difference work variables [R ~> kg m-3] real :: dR0, dR21, dRcv ! Assorted density difference work variables [R ~> kg m-3] + real :: dSpV0, dSpVk1 ! Assorted specific volume difference work variables [R-1 ~> m3 kg-1] real :: dRcv_stays, dRcv_det, dRcv_lim ! Assorted densities [R ~> kg m-3] real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. real :: h2_to_k1_lim ! A limit on the thickness that can be detrained to layer k1 [H ~> m or kg m-2] real :: T_new, T_max, T_min ! Temperature of the detrained water and limits on it [C ~> degC] real :: S_new, S_max, S_min ! Salinity of the detrained water and limits on it [S ~> ppt] - + logical :: stable integer :: i, k, k0, k1, is, ie, nz, kb1, kb2, nkmb + is = G%isc ; ie = G%iec ; nz = GV%ke kb1 = CS%nkml+1; kb2 = CS%nkml+2 nkmb = CS%nkml+CS%nkbl h_neglect = GV%H_subroundoff g_2 = 0.5 * GV%g_Earth Rho0xG = GV%Rho0 * GV%g_Earth + Idt_diag = 1.0 / dt_diag Idt_H2 = GV%H_to_Z**2 / dt_diag - I2Rho0 = 0.5 / (GV%Rho0) + I2Rho0 = 0.5 / GV%Rho0 Angstrom = GV%Angstrom_H ! This is hard coding of arbitrary and dimensional numbers. @@ -2361,12 +2658,16 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! As coded this has the k and i loop orders switched, but k is CS%nkml is ! often just 1 or 2, so this seems like it should not be a problem, especially ! since it means that a number of variables can now be scalars, not arrays. - h_to_bl = 0.0 ; R0_to_bl = 0.0 + h_to_bl = 0.0 ; R0_to_bl = 0.0 ; SpV0_to_bl = 0.0 Rcv_to_bl = 0.0 ; T_to_bl = 0.0 ; S_to_bl = 0.0 do k=1,CS%nkml ; if (h(i,k) > 0.0) then h_to_bl = h_to_bl + h(i,k) - R0_to_bl = R0_to_bl + R0(i,k)*h(i,k) + if (CS%nonBous_energetics) then + SpV0_to_bl = SpV0_to_bl + SpV0(i,k)*h(i,k) + else + R0_to_bl = R0_to_bl + R0(i,k)*h(i,k) + endif Rcv_to_bl = Rcv_to_bl + Rcv(i,k)*h(i,k) T_to_bl = T_to_bl + T(i,k)*h(i,k) @@ -2375,8 +2676,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, d_ea(i,k) = d_ea(i,k) - h(i,k) h(i,k) = 0.0 endif ; enddo - if (h_to_bl > 0.0) then ; R0_det = R0_to_bl / h_to_bl - else ; R0_det = R0(i,0) ; endif + + if (CS%nonBous_energetics) then + if (h_to_bl > 0.0) then ; SpV0_det = SpV0_to_bl / h_to_bl + else ; SpV0_det = SpV0(i,0) ; endif + else + if (h_to_bl > 0.0) then ; R0_det = R0_to_bl / h_to_bl + else ; R0_det = R0(i,0) ; endif + endif ! This code does both downward detrainment from both the mixed layer and the ! buffer layers. @@ -2401,8 +2708,11 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h_min_bl = MIN(CS%Hbuffer_min, CS%Hbuffer_rel_min*h(i,0)) stable_Rcv = .true. - if (((R0(i,kb2)-R0(i,kb1)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) & - stable_Rcv = .false. + if (CS%nonBous_energetics) then + if (((SpV0(i,kb1)-SpV0(i,kb2)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) stable_Rcv = .false. + else + if (((R0(i,kb2)-R0(i,kb1)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) stable_Rcv = .false. + endif h1 = h(i,kb1) ; h2 = h(i,kb2) @@ -2417,26 +2727,36 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! are not meaningful, but may later be used to determine the properties of ! waters moving into the lower buffer layer. So the properties of the ! lower buffer layer are set to be between those of the upper buffer layer - ! and the next denser interior layer, measured by R0. This probably does + ! and the next denser interior layer, measured by R0 or SpV0. This probably does ! not happen very often, so I am not too worried about the inefficiency of ! the following loop. do k1=kb2+1,nz ; if (h(i,k1) > 2.0*Angstrom) exit ; enddo - R0(i,kb2) = R0(i,kb1) - Rcv(i,kb2) = Rcv(i,kb1) ; T(i,kb2) = T(i,kb1) ; S(i,kb2) = S(i,kb1) + if (CS%nonBous_energetics) then + SpV0(i,kb2) = SpV0(i,kb1) + if (k1 <= nz) then ; if (SpV0(i,k1) <= SpV0(i,kb1)) then + SpV0(i,kb2) = 0.5*(SpV0(i,kb1)+SpV0(i,k1)) + + Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) + T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) + S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) + endif ; endif + else + R0(i,kb2) = R0(i,kb1) - if (k1 <= nz) then ; if (R0(i,k1) >= R0(i,kb1)) then - R0(i,kb2) = 0.5*(R0(i,kb1)+R0(i,k1)) + if (k1 <= nz) then ; if (R0(i,k1) >= R0(i,kb1)) then + R0(i,kb2) = 0.5*(R0(i,kb1)+R0(i,k1)) - Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) - T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) - S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) - endif ; endif + Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) + T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) + S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) + endif ; endif + endif endif ! (h2 = 0 && h1 > 0) - dPE_extrap = 0.0 ; dPE_merge = 0.0 + dPE_extrap_rhoG = 0.0 ; dPE_extrapolate = 0.0 ; dPE_merge = 0.0 ; dPE_merge_nB = 0.0 mergeable_bl = .false. if ((h1 > 0.0) .and. (h2 > 0.0) .and. (h_to_bl > 0.0) .and. & (stable_Rcv)) then @@ -2453,12 +2773,23 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! into the lower one, each with an energy change that equals that required ! to mix the detrained water with the upper buffer layer. h1_avail = h1 - MAX(0.0,h_min_bl-h_to_bl) - if ((k1<=nz) .and. (h2 > h_min_bl) .and. (h1_avail > 0.0) .and. & - (R0(i,kb1) < R0(i,kb2)) .and. (h_to_bl*R0(i,kb1) > R0_to_bl)) then - dRk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (R0(i,kb2) - R0(i,kb1)) / & - (Rcv(i,kb2) - Rcv(i,kb1)) - b1 = dRk1 / (R0(i,kb2) - R0(i,kb1)) + if (CS%nonBous_energetics) then + intermediate = (SpV0(i,kb1) > SpV0(i,kb2)) .and. (h_to_bl*SpV0(i,kb1) < SpV0_to_bl) + else + intermediate = (R0(i,kb1) < R0(i,kb2)) .and. (h_to_bl*R0(i,kb1) > R0_to_bl) + endif + + if ((k1<=nz) .and. (h2 > h_min_bl) .and. (h1_avail > 0.0) .and. intermediate) then + if (CS%nonBous_energetics) then + dSpVk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (SpV0(i,kb2) - SpV0(i,kb1)) / & + (Rcv(i,kb2) - Rcv(i,kb1)) + b1 = (RcvTgt(k1) - Rcv(i,kb2)) / (Rcv(i,kb2) - Rcv(i,kb1)) + else + dRk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (R0(i,kb2) - R0(i,kb1)) / & + (Rcv(i,kb2) - Rcv(i,kb1)) + b1 = dRk1 / (R0(i,kb2) - R0(i,kb1)) ! b1 = RcvTgt(k1) - Rcv(i,kb2)) / (Rcv(i,kb2) - Rcv(i,kb1)) + endif ! Apply several limits to the detrainment. ! Entrain less than the mass in h2, and keep the base of the buffer @@ -2468,8 +2799,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! buffer layers with upwind advection from the layer above. if (h2_to_k1*(h1_avail + b1*(h1_avail + h2)) > h2*h1_avail) & h2_to_k1 = (h2*h1_avail) / (h1_avail + b1*(h1_avail + h2)) - if (h2_to_k1*(dRk1 * h2) > (h_to_bl*R0(i,kb1) - R0_to_bl) * h1) & - h2_to_k1 = (h_to_bl*R0(i,kb1) - R0_to_bl) * h1 / (dRk1 * h2) + + if (CS%nonBous_energetics) then + if (h2_to_k1*(dSpVk1 * h2) < (h_to_bl*SpV0(i,kb1) - SpV0_to_bl) * h1) & + h2_to_k1 = (h_to_bl*SpV0(i,kb1) - SpV0_to_bl) * h1 / (dSpVk1 * h2) + else + if (h2_to_k1*(dRk1 * h2) > (h_to_bl*R0(i,kb1) - R0_to_bl) * h1) & + h2_to_k1 = (h_to_bl*R0(i,kb1) - R0_to_bl) * h1 / (dRk1 * h2) + endif if ((k1==kb2+1) .and. (CS%BL_extrap_lim > 0.)) then ! Simply do not detrain very light water into the lightest isopycnal @@ -2511,9 +2848,15 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv + dRcv_dS(i) * dSpice_det) S_det = S(i,kb2) + I_denom * & (dRcv_dS(i) * dRcv - dT_dS_gauge * dRcv_dT(i) * dSpice_det) - ! The detrained values of R0 are based on changes in T and S. - R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & - (S_det-S(i,kb2)) * dR0_dS(i) + + ! The detrained values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb2) + (T_det-T(i,kb2)) * dSpV0_dT(i) + & + (S_det-S(i,kb2)) * dSpV0_dS(i) + else + R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & + (S_det-S(i,kb2)) * dR0_dS(i) + endif if (CS%BL_extrap_lim >= 0.) then ! Only do this detrainment if the new layer's temperature and salinity @@ -2555,10 +2898,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h1_to_h2*S(i,kb1)) * Ih2f S(i,k1) = ((h(i,k1)+h_neglect)*S(i,k1) + h2_to_k1*S_det) * Ihk1 - ! Changes in R0 are based on changes in T and S. - R0(i,kb2) = ((h(i,kb2)*R0(i,kb2) - h2_to_k1*R0_det) + & - h1_to_h2*R0(i,kb1)) * Ih2f - R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + ! Changes in R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0(i,kb2) = ((h(i,kb2)*SpV0(i,kb2) - h2_to_k1*SpV0_det) + h1_to_h2*SpV0(i,kb1)) * Ih2f + SpV0(i,k1) = ((h(i,k1)+h_neglect)*SpV0(i,k1) + h2_to_k1*SpV0_det) * Ihk1 + else + R0(i,kb2) = ((h(i,kb2)*R0(i,kb2) - h2_to_k1*R0_det) + h1_to_h2*R0(i,kb1)) * Ih2f + R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + endif h(i,kb1) = h(i,kb1) - h1_to_h2 ; h1 = h(i,kb1) h(i,kb2) = (h(i,kb2) - h2_to_k1) + h1_to_h2 ; h2 = h(i,kb2) @@ -2579,8 +2926,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, k0 = k1-1 dR1 = RcvTgt(k0)-Rcv(i,kb1) ; dR2 = Rcv(i,kb2)-RcvTgt(k0) - if ((k0>kb2) .and. (dR1 > 0.0) .and. (h1 > h_min_bl) .and. & - (h2*dR2 < h1*dR1) .and. (R0(i,kb2) > R0(i,kb1))) then + if (CS%nonBous_energetics) then + stable = (SpV0(i,kb2) < SpV0(i,kb1)) + else + stable = (R0(i,kb2) > R0(i,kb1)) + endif + + if ((k0>kb2) .and. (dR1 > 0.0) .and. (h1 > h_min_bl) .and. (h2*dR2 < h1*dR1) .and. stable) then ! An interior isopycnal layer (k0) is intermediate in density between ! the two buffer layers, and there can be detrainment. The entire ! lower buffer layer is combined with a portion of the upper buffer @@ -2589,12 +2941,20 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ((dR1+dR2)*h1 + dR1*(h1+h2) + & sqrt((dR2*h1-dR1*h2)**2 + 4*(h1+h2)*h2*(dR1+dR2)*dR2)) - stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & - h1 - (h1+h2)*(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1))) - if ((stays_merge > stays_min_merge) .and. & - (stays_merge + h2_to_k1_rem >= h1 + h2)) then - mergeable_bl = .true. - dPE_merge = g_2*(R0(i,kb2)-R0(i,kb1))*(h1-stays_merge)*(h2-stays_merge) + if (CS%nonBous_energetics) then + stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & + h1 - (h1+h2)*(SpV0(i,kb1) - SpV0_det) / (SpV0(i,kb2) - SpV0(i,kb1))) + if ((stays_merge > stays_min_merge) .and. (stays_merge + h2_to_k1_rem >= h1 + h2)) then + mergeable_bl = .true. + dPE_merge_nB = g_2*GV%H_to_RZ**2*(SpV0(i,kb1)-SpV0(i,kb2)) * ((h1-stays_merge)*(h2-stays_merge)) + endif + else + stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & + h1 - (h1+h2)*(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1))) + if ((stays_merge > stays_min_merge) .and. (stays_merge + h2_to_k1_rem >= h1 + h2)) then + mergeable_bl = .true. + dPE_merge = g_2*(R0(i,kb2)-R0(i,kb1)) * (h1-stays_merge)*(h2-stays_merge) + endif endif endif @@ -2635,9 +2995,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv + dRcv_dS(i) * dSpice_det) S_det = S(i,kb2) + I_denom * & (dRcv_dS(i) * dRcv - dT_dS_gauge * dRcv_dT(i) * dSpice_det) - ! The detrained values of R0 are based on changes in T and S. - R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & - (S_det-S(i,kb2)) * dR0_dS(i) + ! The detrained values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb2) + (T_det-T(i,kb2)) * dSpV0_dT(i) + & + (S_det-S(i,kb2)) * dSpV0_dS(i) + else + R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & + (S_det-S(i,kb2)) * dR0_dS(i) + endif ! Now that the properties of the detrained water are known, ! potentially limit the amount of water that is detrained to @@ -2703,9 +3068,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, S(i,kb2) = (h2*S(i,kb2) - h2_to_k1*S_det) * Ih2f S(i,k1) = ((h(i,k1)+h_neglect)*S(i,k1) + h2_to_k1*S_det) * Ihk1 - ! Changes in R0 are based on changes in T and S. - R0(i,kb2) = (h2*R0(i,kb2) - h2_to_k1*R0_det) * Ih2f - R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + ! Changes in R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0(i,kb2) = (h2*SpV0(i,kb2) - h2_to_k1*SpV0_det) * Ih2f + SpV0(i,k1) = ((h(i,k1)+h_neglect)*SpV0(i,k1) + h2_to_k1*SpV0_det) * Ihk1 + else + R0(i,kb2) = (h2*R0(i,kb2) - h2_to_k1*R0_det) * Ih2f + R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + endif else ! h2==h2_to_k1 can happen if dR2b = 0 exactly, but this is very ! unlikely. In this case the entirety of layer kb2 is detrained. @@ -2715,13 +3085,22 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, Rcv(i,k1) = (h(i,k1)*Rcv(i,k1) + h2*Rcv(i,kb2)) * Ihk1 T(i,k1) = (h(i,k1)*T(i,k1) + h2*T(i,kb2)) * Ihk1 S(i,k1) = (h(i,k1)*S(i,k1) + h2*S(i,kb2)) * Ihk1 - R0(i,k1) = (h(i,k1)*R0(i,k1) + h2*R0(i,kb2)) * Ihk1 + if (CS%nonBous_energetics) then + SpV0(i,k1) = (h(i,k1)*SpV0(i,k1) + h2*SpV0(i,kb2)) * Ihk1 + else + R0(i,k1) = (h(i,k1)*R0(i,k1) + h2*R0(i,kb2)) * Ihk1 + endif endif h(i,k1) = h(i,k1) + h2_to_k1 h(i,kb2) = h(i,kb2) - h2_to_k1 ; h2 = h(i,kb2) - ! dPE_extrap should be positive here. - dPE_extrap = I2Rho0*(R0_det-R0(i,kb2))*h2_to_k1*h2 + ! dPE_extrap_rhoG should be positive here. + if (CS%nonBous_energetics) then + dPE_extrap_rhoG = 0.5*(SpV0(i,kb2)-SpV0_det) * (h2_to_k1*h2) / SpV0(i,k1) + dPE_extrapolate = 0.5*GV%g_Earth*GV%H_to_RZ**2*(SpV0(i,kb2)-SpV0_det) * (h2_to_k1*h2) + else + dPE_extrap_rhoG = I2Rho0*(R0_det-R0(i,kb2))*h2_to_k1*h2 + endif d_ea(i,kb2) = d_ea(i,kb2) - h2_to_k1 d_ea(i,k1) = d_ea(i,k1) + h2_to_k1 @@ -2748,9 +3127,15 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, Ihdet = 0.0 ; if (h_to_bl > 0.0) Ihdet = 1.0 / h_to_bl Ih1f = 1.0 / (h_det_to_h1 + h_ml_to_h1) - R0(i,kb2) = ((h2*R0(i,kb2) + h1*R0(i,kb1)) + & - (h_det_to_h2*R0_to_bl*Ihdet + h_ml_to_h2*R0(i,0))) * Ih - R0(i,kb1) = (h_det_to_h1*R0_to_bl*Ihdet + h_ml_to_h1*R0(i,0)) * Ih1f + if (CS%nonBous_energetics) then + SpV0(i,kb2) = ((h2*SpV0(i,kb2) + h1*SpV0(i,kb1)) + & + (h_det_to_h2*SpV0_to_bl*Ihdet + h_ml_to_h2*SpV0(i,0))) * Ih + SpV0(i,kb1) = (h_det_to_h1*SpV0_to_bl*Ihdet + h_ml_to_h1*SpV0(i,0)) * Ih1f + else + R0(i,kb2) = ((h2*R0(i,kb2) + h1*R0(i,kb1)) + & + (h_det_to_h2*R0_to_bl*Ihdet + h_ml_to_h2*R0(i,0))) * Ih + R0(i,kb1) = (h_det_to_h1*R0_to_bl*Ihdet + h_ml_to_h1*R0(i,0)) * Ih1f + endif Rcv(i,kb2) = ((h2*Rcv(i,kb2) + h1*Rcv(i,kb1)) + & (h_det_to_h2*Rcv_to_bl*Ihdet + h_ml_to_h2*Rcv(i,0))) * Ih @@ -2774,18 +3159,30 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (allocated(CS%diag_PE_detrain) .or. allocated(CS%diag_PE_detrain2)) then - R0_det = R0_to_bl*Ihdet - s1en = g_2 * Idt_H2 * ( ((R0(i,kb2)-R0(i,kb1))*h1*h2 + & - h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & - h_ml_to_h2*( (R0(i,kb2)-R0(i,0))*h2 + (R0(i,kb1)-R0(i,0))*h1 + & - (R0_det-R0(i,0))*h_det_to_h2 ) + & - h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap ) + if (CS%nonBous_energetics) then + SpV0_det = SpV0_to_bl*Ihdet + s1en = Idt_diag * ( -GV%H_to_RZ**2 * g_2 * ((SpV0(i,kb2)-SpV0(i,kb1))*h1*h2 + & + h_det_to_h2*( (SpV0(i,kb1)-SpV0_det)*h1 + (SpV0(i,kb2)-SpV0_det)*h2 ) + & + h_ml_to_h2*( (SpV0(i,kb2)-SpV0(i,0))*h2 + (SpV0(i,kb1)-SpV0(i,0))*h1 + & + (SpV0_det-SpV0(i,0))*h_det_to_h2 ) + & + h_det_to_h1*h_ml_to_h1*(SpV0_det-SpV0(i,0))) - dPE_extrapolate ) + + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + s1en + Idt_diag*dPE_extrapolate + else + R0_det = R0_to_bl*Ihdet + s1en = g_2 * Idt_H2 * ( ((R0(i,kb2)-R0(i,kb1))*h1*h2 + & + h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & + h_ml_to_h2*( (R0(i,kb2)-R0(i,0))*h2 + (R0(i,kb1)-R0(i,0))*h1 + & + (R0_det-R0(i,0))*h_det_to_h2 ) + & + h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap_rhoG ) + + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + s1en + Idt_H2*Rho0xG*dPE_extrap_rhoG + endif if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + s1en - - if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + s1en + Idt_H2*Rho0xG*dPE_extrap endif elseif ((h_to_bl > 0.0) .or. (h1 < h_min_bl) .or. (h2 < h_min_bl)) then @@ -2797,8 +3194,18 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (h_from_ml > 0.0) then ! Some water needs to be moved from the mixed layer so that the upper ! (and perhaps lower) buffer layers exceed their minimum thicknesses. - dPE_extrap = dPE_extrap - I2Rho0*h_from_ml*(R0_to_bl - R0(i,0)*h_to_bl) - R0_to_bl = R0_to_bl + h_from_ml*R0(i,0) + if (CS%nonBous_energetics) then + ! The choice of which specific volume to use in the denominator could be revisited. + ! dPE_extrap_rhoG = dPE_extrap_rhoG + 0.5*h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) / SpV0(i,0) + dPE_extrap_rhoG = dPE_extrap_rhoG + 0.5*h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) * & + ( (h_to_bl + h_from_ml) / (SpV0_to_bl + h_from_ml*SpV0(i,0)) ) + dPE_extrapolate = dPE_extrapolate + 0.5*GV%g_Earth*GV%H_to_RZ**2 * & + h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) + SpV0_to_bl = SpV0_to_bl + h_from_ml*SpV0(i,0) + else + dPE_extrap_rhoG = dPE_extrap_rhoG - I2Rho0*h_from_ml*(R0_to_bl - R0(i,0)*h_to_bl) + R0_to_bl = R0_to_bl + h_from_ml*R0(i,0) + endif Rcv_to_bl = Rcv_to_bl + h_from_ml*Rcv(i,0) T_to_bl = T_to_bl + h_from_ml*T(i,0) S_to_bl = S_to_bl + h_from_ml*S(i,0) @@ -2810,8 +3217,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! The absolute value should be unnecessary and 1e9 is just a large number. b1 = 1.0e9 - if (R0(i,kb2) - R0(i,kb1) > 1.0e-9*abs(R0(i,kb1) - R0_det)) & - b1 = abs(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1)) + if (CS%nonBous_energetics) then + if (SpV0(i,kb1) - SpV0(i,kb2) > 1.0e-9*abs(SpV0_det - SpV0(i,kb1))) & + b1 = abs(SpV0_det - SpV0(i,kb1)) / (SpV0(i,kb1) - SpV0(i,kb2)) + else + if (R0(i,kb2) - R0(i,kb1) > 1.0e-9*abs(R0(i,kb1) - R0_det)) & + b1 = abs(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1)) + endif stays_min = MAX((1.0-b1)*h1 - b1*h2, 0.0, h_min_bl - h_to_bl) stays_max = h1 - MAX(h_min_bl-h2,0.0) @@ -2831,9 +3243,9 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (s2 < 0.0) then ! The energy released by detrainment from the lower buffer layer can be ! used to mix water from the upper buffer layer into the lower one. - s3sq = I_ya*MAX(bh0*h1-dPE_extrap, 0.0) + s3sq = I_ya*MAX(bh0*h1-dPE_extrap_rhoG, 0.0) else - s3sq = I_ya*(bh0*h1-MIN(dPE_extrap,0.0)) + s3sq = I_ya*(bh0*h1-MIN(dPE_extrap_rhoG,0.0)) endif if (s3sq == 0.0) then @@ -2871,10 +3283,17 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, endif endif - dPE_det = g_2*((R0(i,kb1)*h_to_bl - R0_to_bl)*stays + & - (R0(i,kb2)-R0(i,kb1)) * (h1-stays) * & - (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & - Rho0xG*dPE_extrap + if (CS%nonBous_energetics) then + dPE_det_nB = -g_2*GV%H_to_RZ**2*((SpV0(i,kb1)*h_to_bl - SpV0_to_bl)*stays + & + (SpV0(i,kb2)-SpV0(i,kb1)) * (h1-stays) * & + (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & + dPE_extrapolate + else + dPE_det = g_2*((R0(i,kb1)*h_to_bl - R0_to_bl)*stays + & + (R0(i,kb2)-R0(i,kb1)) * (h1-stays) * & + (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & + Rho0xG*dPE_extrap_rhoG + endif if (dPE_time_ratio*h_to_bl > h_to_bl+h(i,0)) then dPE_ratio = (h_to_bl+h(i,0)) / h_to_bl @@ -2882,7 +3301,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, dPE_ratio = dPE_time_ratio endif - if ((mergeable_bl) .and. (num_events*dPE_ratio*dPE_det > dPE_merge)) then + if (CS%nonBous_energetics) then + better_to_merge = (num_events*dPE_ratio*dPE_det_nB > dPE_merge_nB) + else + better_to_merge = (num_events*dPE_ratio*dPE_det > dPE_merge) + endif + + if (mergeable_bl .and. better_to_merge) then ! It is energetically preferable to merge the two buffer layers, detrain ! them into interior layer (k0), move the remaining upper buffer layer ! water into the lower buffer layer, and detrain undiluted into the @@ -2909,8 +3334,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, I_denom = 1.0 / (dRcv_dS(i)**2 + (dT_dS_gauge*dRcv_dT(i))**2) dSpice_2dz = (dS_dT_gauge*dRcv_dS(i)*(T(i,kb1)-T(i,kb2)) - & dT_dS_gauge*dRcv_dT(i)*(S(i,kb1)-S(i,kb2))) * Ih12 - dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & - dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + if (CS%nonBous_energetics) then + ! Use the specific volume differences to limit the coordinate density change. + dSpice_lim = -Rcv(i,kb1) * (dS_dT_gauge*dSpV0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dSpV0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / (SpV0(i,kb1) * h_to_bl) + else + dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + endif if (dSpice_lim * dSpice_2dz <= 0.0) dSpice_2dz = 0.0 if (stays > 0.0) then @@ -2923,15 +3354,20 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv_stays + dRcv_dS(i) * dSpice_stays) S_stays = S(i,kb1) + I_denom * & (dRcv_dS(i) * dRcv_stays - dT_dS_gauge * dRcv_dT(i) * dSpice_stays) - ! The values of R0 are based on changes in T and S. - R0_stays = R0(i,kb1) + (T_stays-T(i,kb1)) * dR0_dT(i) + & - (S_stays-S(i,kb1)) * dR0_dS(i) + ! The values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_stays = SpV0(i,kb1) + (T_stays-T(i,kb1)) * dSpV0_dT(i) + & + (S_stays-S(i,kb1)) * dSpV0_dS(i) + else + R0_stays = R0(i,kb1) + (T_stays-T(i,kb1)) * dR0_dT(i) + & + (S_stays-S(i,kb1)) * dR0_dS(i) + endif else ! Limit the spiciness of the water that moves into the lower buffer layer. if (abs(dSpice_lim) < abs(dSpice_2dz*h1_to_k0)) & dSpice_2dz = dSpice_lim/h1_to_k0 ! These will be multiplied by 0 later. - T_stays = 0.0 ; S_stays = 0.0 ; R0_stays = 0.0 + T_stays = 0.0 ; S_stays = 0.0 ; R0_stays = 0.0 ; SpV0_stays = 0.0 endif dSpice_det = - dSpice_2dz*(stays + h1_to_h2) @@ -2939,9 +3375,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv_det + dRcv_dS(i) * dSpice_det) S_det = S(i,kb1) + I_denom * & (dRcv_dS(i) * dRcv_det - dT_dS_gauge * dRcv_dT(i) * dSpice_det) - ! The values of R0 are based on changes in T and S. - R0_det = R0(i,kb1) + (T_det-T(i,kb1)) * dR0_dT(i) + & - (S_det-S(i,kb1)) * dR0_dS(i) + ! The values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb1) + (T_det-T(i,kb1)) * dSpV0_dT(i) + & + (S_det-S(i,kb1)) * dSpV0_dS(i) + else + R0_det = R0(i,kb1) + (T_det-T(i,kb1)) * dR0_dT(i) + & + (S_det-S(i,kb1)) * dR0_dS(i) + endif T(i,k0) = ((h1_to_k0*T_det + h2*T(i,kb2)) + h(i,k0)*T(i,k0)) * Ihk0 T(i,kb2) = (h1*T(i,kb1) - stays*T_stays - h1_to_k0*T_det) * Ih2f @@ -2951,29 +3392,40 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, S(i,kb2) = (h1*S(i,kb1) - stays*S_stays - h1_to_k0*S_det) * Ih2f S(i,kb1) = (S_to_bl + stays*S_stays) * Ih1f - R0(i,k0) = ((h1_to_k0*R0_det + h2*R0(i,kb2)) + h(i,k0)*R0(i,k0)) * Ihk0 - R0(i,kb2) = (h1*R0(i,kb1) - stays*R0_stays - h1_to_k0*R0_det) * Ih2f - R0(i,kb1) = (R0_to_bl + stays*R0_stays) * Ih1f + if (CS%nonBous_energetics) then + SpV0(i,k0) = ((h1_to_k0*SpV0_det + h2*SpV0(i,kb2)) + h(i,k0)*SpV0(i,k0)) * Ihk0 + SpV0(i,kb2) = (h1*SpV0(i,kb1) - stays*SpV0_stays - h1_to_k0*SpV0_det) * Ih2f + SpV0(i,kb1) = (SpV0_to_bl + stays*SpV0_stays) * Ih1f + else + R0(i,k0) = ((h1_to_k0*R0_det + h2*R0(i,kb2)) + h(i,k0)*R0(i,k0)) * Ihk0 + R0(i,kb2) = (h1*R0(i,kb1) - stays*R0_stays - h1_to_k0*R0_det) * Ih2f + R0(i,kb1) = (R0_to_bl + stays*R0_stays) * Ih1f + endif ! ! The following is 2nd-order upwind advection without limiters. ! dT_2dz = (T(i,kb1) - T(i,kb2)) * Ih12 ! T(i,k0) = (h1_to_k0*(T(i,kb1) - dT_2dz*(stays+h1_to_h2)) + & ! h2*T(i,kb2) + h(i,k0)*T(i,k0)) * Ihk0 ! T(i,kb2) = T(i,kb1) + dT_2dz*(h1_to_k0-stays) -! T(i,kb1) = (T_to_bl + stays*(T(i,kb1) + & -! dT_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! T(i,kb1) = (T_to_bl + stays*(T(i,kb1) + dT_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f ! dS_2dz = (S(i,kb1) - S(i,kb2)) * Ih12 ! S(i,k0) = (h1_to_k0*(S(i,kb1) - dS_2dz*(stays+h1_to_h2)) + & ! h2*S(i,kb2) + h(i,k0)*S(i,k0)) * Ihk0 ! S(i,kb2) = S(i,kb1) + dS_2dz*(h1_to_k0-stays) -! S(i,kb1) = (S_to_bl + stays*(S(i,kb1) + & -! dS_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f -! dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih12 -! R0(i,k0) = (h1_to_k0*(R0(i,kb1) - dR0_2dz*(stays+h1_to_h2)) + & -! h2*R0(i,kb2) + h(i,k0)*R0(i,k0)) * Ihk0 -! R0(i,kb2) = R0(i,kb1) + dR0_2dz*(h1_to_k0-stays) -! R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + & -! dR0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! S(i,kb1) = (S_to_bl + stays*(S(i,kb1) + dS_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! if (CS%nonBous_energetics) then +! dSpV0_2dz = (SpV0(i,kb1) - SpV0(i,kb2)) * Ih12 +! SpV0(i,k0) = (h1_to_k0*(SpV0(i,kb1) - dSpV0_2dz*(stays+h1_to_h2)) + & +! h2*SpV0(i,kb2) + h(i,k0)*SpV0(i,k0)) * Ihk0 +! SpV0(i,kb2) = SpV0(i,kb1) + dSpV0_2dz*(h1_to_k0-stays) +! SpV0(i,kb1) = (SpV0_to_bl + stays*(SpV0(i,kb1) + dSpV0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! else +! dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih12 +! R0(i,k0) = (h1_to_k0*(R0(i,kb1) - dR0_2dz*(stays+h1_to_h2)) + & +! h2*R0(i,kb2) + h(i,k0)*R0(i,k0)) * Ihk0 +! R0(i,kb2) = R0(i,kb1) + dR0_2dz*(h1_to_k0-stays) +! R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + dR0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! endif d_ea(i,kb1) = (d_ea(i,kb1) + h_to_bl) + (stays - h1) d_ea(i,kb2) = d_ea(i,kb2) + (h1_to_h2 - h2) @@ -2982,10 +3434,17 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h(i,kb1) = stays + h_to_bl h(i,kb2) = h1_to_h2 h(i,k0) = h(i,k0) + (h1_to_k0 + h2) - if (allocated(CS%diag_PE_detrain)) & - CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_merge - if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_diag*dPE_merge_nB + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_diag*(dPE_det_nB + dPE_extrapolate) + else + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_merge + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap_rhoG) + endif else ! Not mergeable_bl. ! There is no further detrainment from the buffer layers, and the ! upper buffer layer water is distributed optimally between the @@ -2993,37 +3452,64 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h1_to_h2 = h1 - stays Ih1f = 1.0 / (h_to_bl + stays) ; Ih2f = 1.0 / (h2 + h1_to_h2) Ih = 1.0 / (h1 + h2) - dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih - R0(i,kb2) = (h2*R0(i,kb2) + h1_to_h2*(R0(i,kb1) - & - scale_slope*dR0_2dz*stays)) * Ih2f - R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + & - scale_slope*dR0_2dz*h1_to_h2)) * Ih1f - - ! Use 2nd order upwind advection of spiciness, limited by the value - ! in the detrained water to determine the detrained temperature and - ! salinity. - dR0 = scale_slope*dR0_2dz*h1_to_h2 - dSpice_stays = (dS_dT_gauge*dR0_dS(i)*(T(i,kb1)-T(i,kb2)) - & - dT_dS_gauge*dR0_dT(i)*(S(i,kb1)-S(i,kb2))) * & - scale_slope*h1_to_h2 * Ih - if (h_to_bl > 0.0) then - dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & - dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) /& - h_to_bl + if (CS%nonBous_energetics) then + dSpV0_2dz = (SpV0(i,kb1) - SpV0(i,kb2)) * Ih + SpV0(i,kb2) = (h2*SpV0(i,kb2) + h1_to_h2*(SpV0(i,kb1) - scale_slope*dSpV0_2dz*stays)) * Ih2f + SpV0(i,kb1) = (SpV0_to_bl + stays*(SpV0(i,kb1) + scale_slope*dSpV0_2dz*h1_to_h2)) * Ih1f else - dSpice_lim = dS_dT_gauge*dR0_dS(i)*(T(i,0)-T(i,kb1)) - & - dT_dS_gauge*dR0_dT(i)*(S(i,0)-S(i,kb1)) + dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih + R0(i,kb2) = (h2*R0(i,kb2) + h1_to_h2*(R0(i,kb1) - scale_slope*dR0_2dz*stays)) * Ih2f + R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + scale_slope*dR0_2dz*h1_to_h2)) * Ih1f endif - if (dSpice_stays*dSpice_lim <= 0.0) then - dSpice_stays = 0.0 - elseif (abs(dSpice_stays) > abs(dSpice_lim)) then - dSpice_stays = dSpice_lim + + ! Use 2nd order upwind advection of spiciness, limited by the value in the + ! detrained water to determine the detrained temperature and salinity. + if (CS%nonBous_energetics) then + dSpV0 = scale_slope*dSpV0_2dz*h1_to_h2 + dSpiceSpV_stays = (dS_dT_gauge*dSpV0_dS(i)*(T(i,kb1)-T(i,kb2)) - & + dT_dS_gauge*dSpV0_dT(i)*(S(i,kb1)-S(i,kb2))) * & + scale_slope*h1_to_h2 * Ih + if (h_to_bl > 0.0) then + dSpiceSpV_lim = (dS_dT_gauge*dSpV0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dSpV0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + else + dSpiceSpV_lim = dS_dT_gauge*dSpV0_dS(i)*(T(i,0)-T(i,kb1)) - & + dT_dS_gauge*dSpV0_dT(i)*(S(i,0)-S(i,kb1)) + endif + if (dSpiceSpV_stays*dSpiceSpV_lim <= 0.0) then + dSpiceSpV_stays = 0.0 + elseif (abs(dSpiceSpV_stays) > abs(dSpiceSpV_lim)) then + dSpiceSpV_stays = dSpiceSpV_lim + endif + I_denom = 1.0 / (dSpV0_dS(i)**2 + (dT_dS_gauge*dSpV0_dT(i))**2) + T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dSpV0_dT(i) * dSpV0 + dSpV0_dS(i) * dSpiceSpV_stays) + S_stays = S(i,kb1) + I_denom * & + (dSpV0_dS(i) * dSpV0 - dT_dS_gauge * dSpV0_dT(i) * dSpiceSpV_stays) + else + dR0 = scale_slope*dR0_2dz*h1_to_h2 + dSpice_stays = (dS_dT_gauge*dR0_dS(i)*(T(i,kb1)-T(i,kb2)) - & + dT_dS_gauge*dR0_dT(i)*(S(i,kb1)-S(i,kb2))) * & + scale_slope*h1_to_h2 * Ih + if (h_to_bl > 0.0) then + dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + else + dSpice_lim = dS_dT_gauge*dR0_dS(i)*(T(i,0)-T(i,kb1)) - & + dT_dS_gauge*dR0_dT(i)*(S(i,0)-S(i,kb1)) + endif + if (dSpice_stays*dSpice_lim <= 0.0) then + dSpice_stays = 0.0 + elseif (abs(dSpice_stays) > abs(dSpice_lim)) then + dSpice_stays = dSpice_lim + endif + I_denom = 1.0 / (dR0_dS(i)**2 + (dT_dS_gauge*dR0_dT(i))**2) + T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dR0_dT(i) * dR0 + dR0_dS(i) * dSpice_stays) + S_stays = S(i,kb1) + I_denom * & + (dR0_dS(i) * dR0 - dT_dS_gauge * dR0_dT(i) * dSpice_stays) endif - I_denom = 1.0 / (dR0_dS(i)**2 + (dT_dS_gauge*dR0_dT(i))**2) - T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & - (dT_dS_gauge * dR0_dT(i) * dR0 + dR0_dS(i) * dSpice_stays) - S_stays = S(i,kb1) + I_denom * & - (dR0_dS(i) * dR0 - dT_dS_gauge * dR0_dT(i) * dSpice_stays) + ! The detrained values of Rcv are based on changes in T and S. Rcv_stays = Rcv(i,kb1) + (T_stays-T(i,kb1)) * dRcv_dT(i) + & (S_stays-S(i,kb1)) * dRcv_dS(i) @@ -3058,10 +3544,19 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h(i,kb1) = stays + h_to_bl h(i,kb2) = h(i,kb2) + h1_to_h2 - if (allocated(CS%diag_PE_detrain)) & - CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_det - if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_diag*dPE_det_nB + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_diag*(dPE_det_nB + dPE_extrapolate) + else + ! Recasting dPE_det into the same units as dPE_det_nB changes these diagnostics slightly + ! in some cases for reasons that are not understood. + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_det + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap_rhoG) + endif endif endif ! End of detrainment... @@ -3072,7 +3567,7 @@ end subroutine mixedlayer_detrain_2 !> This subroutine moves any water left in the former mixed layers into the !! single buffer layers and may also move buffer layer water into the interior !! isopycnal layers. -subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_eb, & +subroutine mixedlayer_detrain_1(h, T, S, R0, SpV0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_eb, & j, G, GV, US, CS, dRcv_dT, dRcv_dS, max_BL_det) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -3082,6 +3577,8 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg] real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each @@ -3126,18 +3623,26 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e ! extrapolating [S R-1 ~> ppt m3 kg-1] real :: dRml ! The density range within the extent of the mixed layers [R ~> kg m-3] real :: dR0_dRcv ! The relative changes in the potential density and the coordinate density [nondim] + real :: dSpV0_dRcv ! The relative changes in the specific volume and the coordinate density [R-2 ~> m6 kg-2] real :: I_denom ! A work variable [S2 R-2 ~> ppt2 m6 kg-2]. real :: Sdown ! The salinity of the detrained water [S ~> ppt] real :: Tdown ! The temperature of the detrained water [C ~> degC] real :: dt_Time ! The timestep divided by the detrainment timescale [nondim]. - real :: g_H2_2Rho0dt ! Half the gravitational acceleration times the square of the + real :: g_H_2Rho0dt ! Half the gravitational acceleration times the ! conversion from H to m divided by the mean density times the time - ! step [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! step [L2 T-3 H-1 R-1 ~> m4 s-3 kg-1 or m7 s-3 kg-2]. real :: g_H2_2dt ! Half the gravitational acceleration times the square of the ! conversion from H to Z divided by the diagnostic time step ! [L2 Z H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. + real :: nB_g_H_2dt ! Half the gravitational acceleration times the conversion from + ! H to RZ divided by the diagnostic time step + ! [L2 R H-1 T-3 ~> kg m s-3 or m4 s-3]. + real :: nB_gRZ_H2_2dt ! Half the gravitational acceleration times the conversion from + ! H to RZ squared divided by the diagnostic time step + ! [L2 R2 Z H-2 T-3 ~> kg2 m-2 s-3 or m4 s-3]. real :: x1 ! A temporary work variable [various] logical :: splittable_BL(SZI_(G)), orthogonal_extrap + logical :: must_unmix integer :: i, is, ie, k, k1, nkmb, nz is = G%isc ; ie = G%iec ; nz = GV%ke @@ -3146,24 +3651,45 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e "CS%nkbl must be 1 in mixedlayer_detrain_1.") dt_Time = dt / CS%BL_detrain_time - g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0 * dt_diag) - g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) + + if (CS%nonBous_energetics) then + nB_g_H_2dt = (GV%g_Earth * GV%H_to_RZ) / (2.0 * dt_diag) + nB_gRZ_H2_2dt = GV%H_to_RZ * nB_g_H_2dt + else + g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) + g_H_2Rho0dt = g_H2_2dt * GV%RZ_to_H + endif ! Move detrained water into the buffer layer. do k=1,CS%nkml do i=is,ie ; if (h(i,k) > 0.0) then Ih = 1.0 / (h(i,nkmb) + h(i,k)) - if (CS%TKE_diagnostics) & - CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & - g_H2_2Rho0dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - if (allocated(CS%diag_PE_detrain)) & - CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + & - g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - if (allocated(CS%diag_PE_detrain2)) & - CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + & - g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - - R0(i,nkmb) = (R0(i,nkmb)*h(i,nkmb) + R0(i,k)*h(i,k)) * Ih + + if (CS%nonBous_energetics) then + if (CS%TKE_diagnostics) & + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) - & + nB_g_H_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - & + nB_gRZ_H2_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) - & + nB_gRZ_H2_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + + SpV0(i,nkmb) = (SpV0(i,nkmb)*h(i,nkmb) + SpV0(i,k)*h(i,k)) * Ih + else + if (CS%TKE_diagnostics) & + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & + g_H_2Rho0dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + & + g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + & + g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + + R0(i,nkmb) = (R0(i,nkmb)*h(i,nkmb) + R0(i,k)*h(i,k)) * Ih + endif Rcv(i,nkmb) = (Rcv(i,nkmb)*h(i,nkmb) + Rcv(i,k)*h(i,k)) * Ih T(i,nkmb) = (T(i,nkmb)*h(i,nkmb) + T(i,k)*h(i,k)) * Ih S(i,nkmb) = (S(i,nkmb)*h(i,nkmb) + S(i,k)*h(i,k)) * Ih @@ -3193,11 +3719,24 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e ! the released buoyancy. With multiple buffer layers, much more ! graceful options are available. do i=is,ie ; if (h(i,nkmb) > 0.0) then - if ((R0(i,0) < R0(i,nz)) .and. (R0(i,nz) < R0(i,nkmb))) then - if ((R0(i,nz)-R0(i,0))*h(i,0) > (R0(i,nkmb)-R0(i,nz))*h(i,nkmb)) then - detrain(i) = (R0(i,nkmb)-R0(i,nz))*h(i,nkmb) / (R0(i,nkmb)-R0(i,0)) + if (CS%nonBous_energetics) then + must_unmix = (SpV0(i,0) > SpV0(i,nz)) .and. (SpV0(i,nz) > SpV0(i,nkmb)) + else + must_unmix = (R0(i,0) < R0(i,nz)) .and. (R0(i,nz) < R0(i,nkmb)) + endif + if (must_unmix) then + if (CS%nonBous_energetics) then + if ((SpV0(i,0)-SpV0(i,nz))*h(i,0) > (SpV0(i,nz)-SpV0(i,nkmb))*h(i,nkmb)) then + detrain(i) = (SpV0(i,nz)-SpV0(i,nkmb))*h(i,nkmb) / (SpV0(i,0)-SpV0(i,nkmb)) + else + detrain(i) = (SpV0(i,0)-SpV0(i,nz))*h(i,0) / (SpV0(i,0)-SpV0(i,nkmb)) + endif else - detrain(i) = (R0(i,nz)-R0(i,0))*h(i,0) / (R0(i,nkmb)-R0(i,0)) + if ((R0(i,nz)-R0(i,0))*h(i,0) > (R0(i,nkmb)-R0(i,nz))*h(i,nkmb)) then + detrain(i) = (R0(i,nkmb)-R0(i,nz))*h(i,nkmb) / (R0(i,nkmb)-R0(i,0)) + else + detrain(i) = (R0(i,nz)-R0(i,0))*h(i,0) / (R0(i,nkmb)-R0(i,0)) + endif endif d_eb(i,CS%nkml) = d_eb(i,CS%nkml) + detrain(i) @@ -3205,12 +3744,22 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e d_eb(i,nkmb) = d_eb(i,nkmb) - detrain(i) d_ea(i,nkmb) = d_ea(i,nkmb) + detrain(i) - if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & - CS%diag_PE_detrain(i,j) + g_H2_2dt * detrain(i)* & - (h(i,0) + h(i,nkmb)) * (R0(i,nkmb) - R0(i,0)) - x1 = R0(i,0) - R0(i,0) = R0(i,0) - detrain(i)*(R0(i,0)-R0(i,nkmb)) / h(i,0) - R0(i,nkmb) = R0(i,nkmb) - detrain(i)*(R0(i,nkmb)-x1) / h(i,nkmb) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + CS%diag_PE_detrain(i,j) - nB_gRZ_H2_2dt * detrain(i)* & + (h(i,0) + h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,0)) + x1 = SpV0(i,0) + SpV0(i,0) = SpV0(i,0) - detrain(i)*(SpV0(i,0)-SpV0(i,nkmb)) / h(i,0) + SpV0(i,nkmb) = SpV0(i,nkmb) - detrain(i)*(SpV0(i,nkmb)-x1) / h(i,nkmb) + else + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + CS%diag_PE_detrain(i,j) + g_H2_2dt * detrain(i)* & + (h(i,0) + h(i,nkmb)) * (R0(i,nkmb) - R0(i,0)) + x1 = R0(i,0) + R0(i,0) = R0(i,0) - detrain(i)*(R0(i,0)-R0(i,nkmb)) / h(i,0) + R0(i,nkmb) = R0(i,nkmb) - detrain(i)*(R0(i,nkmb)-x1) / h(i,nkmb) + endif + x1 = Rcv(i,0) Rcv(i,0) = Rcv(i,0) - detrain(i)*(Rcv(i,0)-Rcv(i,nkmb)) / h(i,0) Rcv(i,nkmb) = Rcv(i,nkmb) - detrain(i)*(Rcv(i,nkmb)-x1) / h(i,nkmb) @@ -3258,9 +3807,13 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e else ; orthogonal_extrap = .true. ; endif endif - if ((R0(i,0) >= R0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle - ! In this case there is an inversion of in-situ density relative to - ! the coordinate variable. Do not detrain from the buffer layer. + ! Check for the case when there is an inversion of in-situ density relative to + ! the coordinate variable. Do not detrain from the buffer layer in this case. + if (CS%nonBous_energetics) then + if ((SpV0(i,0) <= SpV0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle + else + if ((R0(i,0) >= R0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle + endif if (orthogonal_extrap) then ! 36 here is a typical oceanic value of (dR/dS) / (dR/dT) - it says @@ -3273,20 +3826,33 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e dT_dR = (T(i,0) - T(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) dS_dR = (S(i,0) - S(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) endif - dRml = dt_Time * (R0(i,nkmb) - R0(i,0)) * & - (Rcv(i,0) - Rcv(i,k1)) / (R0(i,0) - R0(i,k1)) - ! Once again, there is an apparent density inversion in Rcv. - if (dRml < 0.0) cycle - dR0_dRcv = (R0(i,0) - R0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + + if (CS%nonBous_energetics) then + dRml = dt_Time * (SpV0(i,0) - SpV0(i,nkmb)) * & + (Rcv(i,0) - Rcv(i,k1)) / (SpV0(i,k1) - SpV0(i,0)) + if (dRml < 0.0) cycle ! Once again, there is an apparent density inversion in Rcv. + dSpV0_dRcv = (SpV0(i,0) - SpV0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + else + dRml = dt_Time * (R0(i,nkmb) - R0(i,0)) * & + (Rcv(i,0) - Rcv(i,k1)) / (R0(i,0) - R0(i,k1)) + if (dRml < 0.0) cycle ! Once again, there is an apparent density inversion in Rcv. + dR0_dRcv = (R0(i,0) - R0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + endif if ((Rcv(i,nkmb) - dRml < RcvTgt(k)) .and. (max_det_rem(i) > h(i,nkmb))) then ! In this case, the buffer layer is split into two isopycnal layers. - detrain(i) = h(i,nkmb)*(Rcv(i,nkmb) - RcvTgt(k)) / & - (RcvTgt(k+1) - RcvTgt(k)) + detrain(i) = h(i,nkmb) * (Rcv(i,nkmb) - RcvTgt(k)) / & + (RcvTgt(k+1) - RcvTgt(k)) - if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & - CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * & - (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dR0_dRcv + if (allocated(CS%diag_PE_detrain)) then + if (CS%nonBous_energetics) then + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + nB_gRZ_H2_2dt * detrain(i) * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dSpV0_dRcv + else + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dR0_dRcv + endif + endif Tdown = detrain(i) * (T(i,nkmb) + dT_dR*(RcvTgt(k+1)-Rcv(i,nkmb))) T(i,k) = (h(i,k) * T(i,k) + & @@ -3333,9 +3899,15 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e h(i,k+1) = h(i,k+1) + detrain(i) h(i,nkmb) = h(i,nkmb) - detrain(i) - if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & - CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * dR0_dRcv * & - (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + if (allocated(CS%diag_PE_detrain)) then + if (CS%nonBous_energetics) then + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + nB_gRZ_H2_2dt * detrain(i) * dSpV0_dRcv * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + else + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * dR0_dRcv * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + endif + endif endif endif ! (RcvTgt(k) <= Rcv(i,nkmb)) endif ! splittable_BL @@ -3379,7 +3951,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) character(len=40) :: mdl = "MOM_mixed_layer" ! This module's name. real :: omega_frac_dflt ! The default value for ML_OMEGA_FRAC [nondim] real :: ustar_min_dflt ! The default value for BML_USTAR_MIN [Z T-1 ~> m s-1] - real :: Hmix_min_z ! The default value of HMIX_MIN [Z ~> m] + real :: Hmix_min_z ! HMIX_MIN in units of vertical extent [Z ~> m], used to set other defaults integer :: isd, ied, jsd, jed logical :: use_temperature, use_omega isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3438,12 +4010,12 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "HMIX_MIN", Hmix_min_Z, & "The minimum mixed layer depth if the mixed layer depth "//& "is determined dynamically.", units="m", default=0.0, scale=US%m_to_Z) - CS%Hmix_min = GV%Z_to_H * Hmix_min_Z + CS%Hmix_min = GV%m_to_H * (US%Z_to_m * Hmix_min_Z) call get_param(param_file, mdl, "MECH_TKE_FLOOR", CS%mech_TKE_floor, & "A tiny floor on the amount of turbulent kinetic energy that is used when "//& "the mixed layer does not yet contain HMIX_MIN fluid. The default is so "//& "small that its actual value is irrelevant, so long as it is greater than 0.", & - units="m3 s-2", default=1.0e-150, scale=US%m_to_Z*US%m_s_to_L_T**2, & + units="m3 s-2", default=1.0e-150, scale=GV%m_to_H*US%m_s_to_L_T**2, & do_not_log=(Hmix_min_Z<=0.0)) call get_param(param_file, mdl, "LIMIT_BUFFER_DETRAIN", CS%limit_det, & @@ -3520,7 +4092,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "layers before sorting when ML_RESORT is true.", & units="nondim", default=0, fail_if_missing=.true.) ! Fail added by AJA. ! This gives a minimum decay scale that is typically much less than Angstrom. - ustar_min_dflt = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) + ustar_min_dflt = 2e-4*CS%omega*(GV%Angstrom_Z + GV%dZ_subroundoff) call get_param(param_file, mdl, "BML_USTAR_MIN", CS%ustar_min, & "The minimum value of ustar that should be used by the "//& "bulk mixed layer model in setting vertical TKE decay "//& @@ -3528,6 +4100,11 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) units="m s-1", default=US%Z_to_m*US%s_to_T*ustar_min_dflt, scale=US%m_to_Z*US%T_to_s) if (CS%ustar_min<=0.0) call MOM_error(FATAL, "BML_USTAR_MIN must be positive.") + call get_param(param_file, mdl, "BML_NONBOUSINESQ", CS%nonBous_energetics, & + "If true, use non-Boussinesq expressions for the energetic calculations "//& + "used in the bulk mixed layer calculations.", & + default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq)) + call get_param(param_file, mdl, "RESOLVE_EKMAN", CS%Resolve_Ekman, & "If true, the NKML>1 layers in the mixed layer are "//& "chosen to optimally represent the impact of the Ekman "//& @@ -3546,7 +4123,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) if (CS%do_rivermix) & call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & "The depth to which rivers are mixed if DO_RIVERMIX is "//& - "defined.", units="m", default=0.0, scale=US%m_to_Z) + "defined.", units="m", default=0.0, scale=GV%m_to_H) call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & "If true, use the fluxes%runoff_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & @@ -3563,28 +4140,28 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) Time, 'Surface mixed layer depth', 'm', conversion=GV%H_to_m) CS%id_TKE_wind = register_diag_field('ocean_model', 'TKE_wind', diag%axesT1, & Time, 'Wind-stirring source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_RiBulk = register_diag_field('ocean_model', 'TKE_RiBulk', diag%axesT1, & Time, 'Mean kinetic energy source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv = register_diag_field('ocean_model', 'TKE_conv', diag%axesT1, & Time, 'Convective source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_pen_SW = register_diag_field('ocean_model', 'TKE_pen_SW', diag%axesT1, & Time, 'TKE consumed by mixing penetrative shortwave radation through the mixed layer', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_mixing = register_diag_field('ocean_model', 'TKE_mixing', diag%axesT1, & Time, 'TKE consumed by mixing that deepens the mixed layer', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'TKE_mech_decay', diag%axesT1, & Time, 'Mechanical energy decay sink of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'TKE_conv_decay', diag%axesT1, & Time, 'Convective energy decay sink of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv_s2 = register_diag_field('ocean_model', 'TKE_conv_s2', diag%axesT1, & Time, 'Spurious source of mixed layer TKE from sigma2', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_PE_detrain = register_diag_field('ocean_model', 'PE_detrain', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer detrainment', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) From 8d628bdb94303417fb4801d2c61d3c3291b5026c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Aug 2023 12:56:23 -0400 Subject: [PATCH 093/146] +*Non-Boussinesq revision of diabatic_aux This commit changes differential_diffuse_TS, diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy and applyBoundaryFluxesInOut to make them appropriate for use in non-Boussinesq mode, and to eliminate dependencies on the Boussinesq reference density when in that mode. It also adds a new optional argument to extract_optics_slice to enable the use of the layer specific volumes to translate opacities into thickness-based units. The specific set of changes include: - Add the optional argument SpV_avg to extract_optics_slice and use it along with an appropriate value for opacity_scale to optionally convert the units of opacity from [Z-1 ~> m-1] to [H-1 ~> m-1 or m2 kg-1] in non-Boussinesq mode without making use of the Boussinesq reference density. - Use thickness_to_dz and work with internal variables in vertical distances in the denominator of diffusive flux calculations in differential_diffuse_T_S, diagnoseMLDbyDensityDifference and diagnoseMLDbyEnergy. - Refactored diagnoseMLDbyEnergy for probable efficiencies by calling the equation of state with contiguous arguments. - Use specific volume derivatives to calculate non-Boussinesq mode buoyancy fluxes in calculateBuoyancy_Flux1d and applyBoudaryFluxesInOut. - Use the inverse of SpV_avg rather than Rho0 in the calculation of the energy input used to drive river mixing when in non-Boussinesq mode. There are now separate thickness and depth change internal variables in several places to avoid any dependency on the Boussinesq reference density when in non-Boussinesq mode. A total of 8 rescaling factors were eliminated, and in one place, GV%Rho0 was replaced with GV%H_to_RZ. All Boussinesq answers are bitwise identical, but non-Boussinesq answers will change and become less dependent on the Boussinesq reference density, and there is a new optional argument to a publicly visible subroutine. --- .../vertical/MOM_diabatic_aux.F90 | 165 ++++++++++++------ 1 file changed, 108 insertions(+), 57 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 6a5e454d19..95c4d43ad3 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -15,6 +15,7 @@ module MOM_diabatic_aux use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, extractFluxes1d, forcing_SinglePointPrint use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init use MOM_interpolate, only : external_field use MOM_io, only : slasher @@ -31,8 +32,8 @@ module MOM_diabatic_aux public diabatic_aux_init, diabatic_aux_end public make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS, triDiagTS_Eulerian -public find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut, set_pen_shortwave -public diagnoseMLDbyEnergy +public find_uv_at_h, applyBoundaryFluxesInOut, set_pen_shortwave +public diagnoseMLDbyEnergy, diagnoseMLDbyDensityDifference ! 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 @@ -254,6 +255,7 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S [H ~> m or kg m-2]. d1_T, d1_S ! Variables used by the tridiagonal solvers [nondim]. real, dimension(SZI_(G),SZK_(GV)) :: & + dz, & ! Height change across layers [Z ~> m] c1_T, c1_S ! Variables used by the tridiagonal solvers [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)+1) :: & mix_T, mix_S ! Mixing distances in both directions across each interface [H ~> m or kg m-2]. @@ -261,20 +263,27 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) ! added to ensure positive definiteness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: I_h_int ! The inverse of the thickness associated with an interface [H-1 ~> m-1 or m2 kg-1]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: I_dz_int ! The inverse of the height scale associated with an interface [Z-1 ~> m-1]. real :: b_denom_T ! The first term in the denominator for the expression for b1_T [H ~> m or kg m-2]. real :: b_denom_S ! The first term in the denominator for the expression for b1_S [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff !$OMP parallel do default(private) shared(is,ie,js,je,h,h_neglect,dt,Kd_T,Kd_S,G,GV,T,S,nz) do j=js,je + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie - I_h_int = 1.0 / (0.5 * (h(i,j,1) + h(i,j,2)) + h_neglect) - mix_T(i,2) = ((dt * Kd_T(i,j,2)) * GV%Z_to_H) * I_h_int - mix_S(i,2) = ((dt * Kd_S(i,j,2)) * GV%Z_to_H) * I_h_int + I_dz_int = 1.0 / (0.5 * (dz(i,1) + dz(i,2)) + dz_neglect) + mix_T(i,2) = (dt * Kd_T(i,j,2)) * I_dz_int + mix_S(i,2) = (dt * Kd_S(i,j,2)) * I_dz_int h_tr = h(i,j,1) + h_neglect b1_T(i) = 1.0 / (h_tr + mix_T(i,2)) @@ -286,9 +295,9 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) enddo do k=2,nz-1 ; do i=is,ie ! Calculate the mixing across the interface below this layer. - I_h_int = 1.0 / (0.5 * (h(i,j,k) + h(i,j,k+1)) + h_neglect) - mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1)) * GV%Z_to_H) * I_h_int - mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1)) * GV%Z_to_H) * I_h_int + I_dz_int = 1.0 / (0.5 * (dz(i,k) + dz(i,k+1)) + dz_neglect) + mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1))) * I_dz_int + mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1))) * I_dz_int c1_T(i,k) = mix_T(i,K) * b1_T(i) c1_S(i,k) = mix_S(i,K) * b1_S(i) @@ -688,19 +697,22 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! Local variables real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m]. + real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m or kg m-2] + real, dimension(SZI_(G)) :: dZ_N2 ! Summed vertical distance used in N2 calculation [Z ~> m] real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [C ~> degC]. real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [S ~> ppt]. real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. - real, dimension(SZI_(G)) :: dK, dKm1 ! Depths [Z ~> m]. + real, dimension(SZI_(G),SZK_(GV)) :: dZ_2d ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G)) :: dZ, dZm1 ! Layer thicknesses associated with interfaces [Z ~> m] real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixed layer depth [R ~> kg m-3]. real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 ! have been stored already. - real :: gE_Rho0 ! The gravitational acceleration divided by a mean density [Z T-2 R-1 ~> m4 s-2 kg-1]. - real :: dH_subML ! Depth below ML over which to diagnose stratification [H ~> m]. + real :: gE_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! reference density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. + real :: dZ_sub_ML ! Depth below ML over which to diagnose stratification [Z ~> m] real :: aFac ! A nondimensional factor [nondim] real :: ddRho ! A density difference [R ~> kg m-3] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -712,7 +724,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, if (present(id_N2subML)) then if (present(dz_subML)) then id_N2 = id_N2subML - dH_subML = GV%Z_to_H*dz_subML + dZ_sub_ML = dz_subML else call MOM_error(FATAL, "When the diagnostic of the subML stratification is "//& "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& @@ -720,29 +732,32 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, endif endif - gE_rho0 = US%L_to_Z**2*GV%g_Earth / GV%Rho0 + gE_rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pRef_MLD(:) = 0.0 EOSdom(:) = EOS_domain(G%HI) do j=js,je - do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dZ_2d, j, G, GV) + + do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) do i=is,ie deltaRhoAtK(i) = 0. MLD(i,j) = 0. if (id_N2>0) then subMLN2(i,j) = 0.0 - H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 + H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. endif enddo do k=2,nz do i=is,ie - dKm1(i) = dK(i) ! Depth of center of layer K-1 - dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K enddo ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding @@ -752,15 +767,18 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, if (MLD(i,j) == 0.0) then ! Still in the mixed layer. H_subML(i) = H_subML(i) + h(i,j,k) elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. - if (dH_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML + if (dZ_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. dH_N2(i) = 0.5 * h(i,j,k) - elseif (dH_N2(i) + h(i,j,k) < dH_subML) then + dZ_N2(i) = 0.5 * dz_2d(i,k) + elseif (dZ_N2(i) + dZ_2d(i,k) < dZ_sub_ML) then dH_N2(i) = dH_N2(i) + h(i,j,k) + dZ_N2(i) = dZ_N2(i) + dz_2d(i,k) else ! This layer includes the base of the region where N2 is calculated. T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) + dZ_N2(i) = dZ_N2(i) + 0.5 * dz_2d(i,k) N2_region_set(i) = .true. endif endif @@ -776,18 +794,18 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, if ((MLD(i,j) == 0.) .and. (ddRho > 0.) .and. & (deltaRhoAtKm1(i) < densityDiff) .and. (deltaRhoAtK(i) >= densityDiff)) then aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho - MLD(i,j) = dK(i) * aFac + dKm1(i) * (1. - aFac) + MLD(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) endif if (id_SQ > 0) MLD2(i,j) = MLD(i,j)**2 enddo ! i-loop enddo ! k-loop do i=is,ie - if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dK(i) ! Assume mixing to the bottom + if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dZ(i) ! Mixing goes to the bottom enddo if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo - ! if ((.not.N2_region_set(i)) .and. (dH_N2(i) > 0.5*dH_subML)) then + ! if ((.not.N2_region_set(i)) .and. (dZ_N2(i) > 0.5*dZ_sub_ML)) then ! ! Use whatever stratification we can, measured over whatever distance is available? ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) ! N2_region_set(i) = .true. @@ -795,7 +813,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) do i=is,ie ; if ((G%mask2dT(i,j) > 0.0) .and. N2_region_set(i)) then - subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) + subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / dH_N2(i) endif ; enddo endif enddo ! j-loop @@ -844,9 +862,9 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) ! Local variables real, dimension(SZI_(G),SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. real, dimension(SZK_(GV)+1) :: Z_int ! Depths of the interfaces from the surface [Z ~> m] - real, dimension(SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] - real, dimension(SZK_(GV)) :: Rho_c ! A column of layer densities [R ~> kg m-3] - real, dimension(SZK_(GV)) :: pRef_MLD ! The reference pressure for the mixed layer + real, dimension(SZI_(G),SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: Rho_c ! Columns of layer densities [R ~> kg m-3] + real, dimension(SZI_(G)) :: pRef_MLD ! The reference pressure for the mixed layer ! depth calculation [R L2 T-2 ~> Pa] real, dimension(3) :: PE_threshold ! The energy threshold divided by g [R Z2 ~> kg m-1] @@ -881,6 +899,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) real :: Fgx ! The mixing energy difference from the target [R Z2 ~> kg m-1] real :: Fpx ! The derivative of Fgx with x [R Z ~> kg m-2] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: IT, iM integer :: i, j, is, ie, js, je, k, nz @@ -894,15 +913,23 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) PE_threshold(iM) = Mixing_Energy(iM) / (US%L_to_Z**2*GV%g_Earth) enddo - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.0) then + MLD(:,:,:) = 0.0 + + EOSdom(:) = EOS_domain(G%HI) + + do j=js,je + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do k=1,nz + call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD, rho_c(:,k), tv%eqn_of_state, EOSdom) + enddo - call calculate_density(tv%T(i,j,:), tv%S(i,j,:), pRef_MLD, rho_c, tv%eqn_of_state) + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then Z_int(1) = 0.0 do k=1,nz - DZ(k) = h(i,j,k) * GV%H_to_Z - Z_int(K+1) = Z_int(K) - DZ(k) + Z_int(K+1) = Z_int(K) - dZ(i,k) enddo do iM=1,3 @@ -918,11 +945,11 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) do k=1,nz ! This is the unmixed PE cumulative sum from top down - PE = PE + 0.5 * rho_c(k) * (Z_int(K)**2 - Z_int(K+1)**2) + PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) ! This is the depth and integral of density - H_ML_TST = H_ML + DZ(k) - RhoDZ_ML_TST = RhoDZ_ML + rho_c(k) * DZ(k) + H_ML_TST = H_ML + dZ(i,k) + RhoDZ_ML_TST = RhoDZ_ML + Rho_c(i,k) * dZ(i,k) ! The average density assuming all layers including this were mixed Rho_ML = RhoDZ_ML_TST/H_ML_TST @@ -942,8 +969,8 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) D1 = H_ML ! The thickness of the mixed layer (not including this layer) - R2 = rho_c(k) ! The density of this layer - D2 = DZ(k) ! The thickness of this layer + R2 = Rho_c(i,k) ! The density of this layer + D2 = dZ(i,k) ! The thickness of this layer ! This block could be used to calculate the function coefficients if ! we don't reference all values to a surface designated as z=0 @@ -970,7 +997,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) Cc2 = R2 * (D - C) ! First guess for an iteration using Newton's method - X = DZ(k) * 0.5 + X = dZ(i,k) * 0.5 IT=0 do while(IT<10)!We can iterate up to 10 times @@ -1002,7 +1029,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) if (abs(Fgx) > PE_Threshold(iM) * PE_Threshold_fraction) then X2 = X - Fgx / Fpx IT = IT + 1 - if (X2 < 0. .or. X2 > DZ(k)) then + if (X2 < 0. .or. X2 > dZ(i,k)) then ! The iteration seems to be robust, but we need to do something *if* ! things go wrong... How should we treat failed iteration? ! Present solution: Stop trying to compute and just say we can't mix this layer. @@ -1021,10 +1048,8 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) enddo MLD(i,j,iM) = H_ML enddo - else - MLD(i,j,:) = 0.0 - endif - enddo ; enddo + endif ; enddo + enddo if (id_MLD(1) > 0) call post_data(id_MLD(1), MLD(:,:,1), diagPtr) if (id_MLD(2) > 0) call post_data(id_MLD(2), MLD(:,:,2), diagPtr) @@ -1104,6 +1129,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t SurfPressure, & ! Surface pressure (approximated as 0.0) [R L2 T-2 ~> Pa] dRhodT, & ! change in density per change in temperature [R C-1 ~> kg m-3 degC-1] dRhodS, & ! change in density per change in salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] netheat_rate, & ! netheat but for dt=1 [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -1111,6 +1138,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t mixing_depth ! Mixed layer depth [Z -> m] real, dimension(SZI_(G), SZK_(GV)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] + ! dz, & ! Layer thicknesses in depth units [Z ~> m] T2d, & ! A 2-d copy of the layer temperatures [C ~> degC] pen_TKE_2d, & ! The TKE required to homogenize the heating by shortwave radiation within ! a layer [R Z3 T-2 ~> J m-2] @@ -1133,6 +1161,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. real :: GoRho ! g_Earth times a unit conversion factor divided by density ! [Z T-2 R-1 ~> m4 s-2 kg-1] + real :: g_conv ! The gravitational acceleration times the conversion factors from non-Boussinesq + ! thickness units to mass per units area [R Z2 H-1 T-2 ~> kg m-2 s-2 or m s-2] logical :: calculate_energetics ! If true, calculate the energy required to mix the newly added ! water over the topmost grid cell, assuming that the fluxes of heat and salt ! and rejected brine are initially applied in vanishingly thin layers at the @@ -1201,7 +1231,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP EnthalpyConst,MLD) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & - !$OMP IforcingDepthScale, & + !$OMP IforcingDepthScale,g_conv,dSpV_dT,dSpV_dS, & !$OMP dThickness,dTemp,dSalt,hOld,Ithickness, & !$OMP netMassIn,pres,d_pres,p_lay,dSV_dT_2d, & !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & @@ -1244,7 +1274,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! 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%Z_to_H)) + if (nsw>0) then + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=GV%H_to_Z) + else + call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=GV%H_to_RZ, & + SpV_avg=tv%SpV_avg) + endif + endif ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: @@ -1378,6 +1415,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) if (GV%Boussinesq) then RivermixConst = -0.5*(CS%rivermix_depth*dt) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 + elseif (allocated(tv%SpV_avg)) then + RivermixConst = -0.5*(CS%rivermix_depth*dt) * ( US%L_to_Z**2*GV%g_Earth ) / tv%SpV_avg(i,j,1) else RivermixConst = -0.5*(CS%rivermix_depth*dt) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) endif @@ -1610,8 +1649,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! 1) Answers will change due to round-off ! 2) Be sure to save their values BEFORE fluxes are used. if (Calculate_Buoyancy) then - drhodt(:) = 0.0 - drhods(:) = 0.0 netPen_rate(:) = 0.0 ! Sum over bands and attenuate as a function of depth. ! netPen_rate is the netSW as a function of depth, but only the surface value is used here, @@ -1623,20 +1660,34 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo - ! Density derivatives - if (associated(tv%p_surf)) then ; do i=is,ie ; SurfPressure(i) = tv%p_surf(i,j) ; enddo ; endif - call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & - tv%eqn_of_state, EOSdom) ! 1. Adjust netSalt to reflect dilution effect of FW flux ! 2. Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. ! 3. Convert to a buoyancy flux, excluding penetrating SW heating ! BGR-Jul 5, 2017: The contribution of SW heating here needs investigated for ePBL. - do i=is,ie - SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * & - (dRhodS(i) * (netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & - dRhodT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] - enddo + if (associated(tv%p_surf)) then ; do i=is,ie ; SurfPressure(i) = tv%p_surf(i,j) ; enddo ; endif + + if ((.not.GV%Boussinesq) .and. (.not.GV%semi_Boussinesq)) then + g_conv = GV%g_Earth * GV%H_to_RZ * US%L_to_Z**2 + + ! Specific volume derivatives + call calculate_specific_vol_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, EOS_domain(G%HI)) + do i=is,ie + SkinBuoyFlux(i,j) = g_conv * & + (dSpV_dS(i) * ( netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dSpV_dT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] + enddo + else + ! Density derivatives + call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOSdom) + do i=is,ie + SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * & + (dRhodS(i) * ( netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dRhodT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] + enddo + endif endif enddo ! j-loop finish From 3ef5b93390f4cd53d791cb46a86c1d365e51e395 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 20 Aug 2023 15:16:19 -0400 Subject: [PATCH 094/146] Do not allocate ustar and tau_mag together Modified MOM_surface_forcing_gfdl.F90 and MOM_surface_forcing.F90 to allocate either ustar or tau_mag, but not both, in the forcing and mech_forcing types, depending on whether the model is in Boussinesq mode. Also added tests to convert_IOB_to_forces in the FMS_cap code and to routines in MOM_surface_forcing in the solo_driver code to ensure that only arrays that are associated are set. All answers are bitwise identical, but checksum statements for the unused arrays are eliminated when DEBUG = True. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 47 ++++-- .../solo_driver/MOM_surface_forcing.F90 | 147 +++++++++++++----- 2 files changed, 139 insertions(+), 55 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index 164193f6d7..f9f7fe88a0 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -63,6 +63,7 @@ module MOM_surface_forcing_gfdl !! the winds that are being provided in calls to !! update_ocean_model. logical :: use_temperature !< If true, temp and saln used as state variables. + logical :: nonBous !< If true, this run is fully non-Boussinesq real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress [nondim]. real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] @@ -282,8 +283,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! allocation and initialization if this is the first time that this ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., press=.true., & - fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) + call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.not.CS%nonBous, press=.true., & + fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=CS%nonBous) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -718,8 +719,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! allocation and initialization if this is the first time that this ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true., tau_mag=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, & + press=.true., tau_mag=CS%nonBous) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) @@ -792,14 +793,26 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! Set the wind stresses and ustar. if (wt1 <= 0.0) then call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & - ustar=forces%ustar, mag_tau=forces%tau_mag, tau_halo=1) + tau_halo=1) + if (associated(forces%ustar)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=forces%ustar) + if (associated(forces%tau_mag)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=forces%tau_mag) else call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & - ustar=ustar_tmp, mag_tau=tau_mag_tmp, tau_halo=1) - do j=js,je ; do i=is,ie - forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) - forces%tau_mag(i,j) = wt1*forces%tau_mag(i,j) + wt2*tau_mag_tmp(i,j) - enddo ; enddo + tau_halo=1) + if (associated(forces%ustar)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=ustar_tmp) + do j=js,je ; do i=is,ie + forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) + enddo ; enddo + endif + if (associated(forces%tau_mag)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=tau_mag_tmp) + do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = wt1*forces%tau_mag(i,j) + wt2*tau_mag_tmp(i,j) + enddo ; enddo + endif endif ! Find the net mass source in the input forcing without other adjustments. @@ -960,7 +973,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ! Set surface momentum stress related fields as a function of staggering. if (present(taux) .or. present(tauy) .or. & - ((do_ustar.or.do_gustless) .and. .not.associated(IOB%stress_mag)) ) then + ((do_ustar .or. do_tau_mag .or. do_gustless) .and. .not.associated(IOB%stress_mag)) ) then if (wind_stagger == BGRID_NE) then taux_in_B(:,:) = 0.0 ; tauy_in_B(:,:) = 0.0 @@ -1278,6 +1291,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. real :: Flux_const_dflt ! A default piston velocity for restoring surface properties [m day-1] + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq real :: rho_TKE_tidal ! The constant bottom density used to translate tidal amplitudes into the ! tidal bottom TKE input used with INT_TIDE_DISSIPATION [R ~> kg m-3] logical :: new_sim ! False if this simulation was started from a restart file @@ -1320,12 +1335,20 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, mdl, "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + CS%nonBous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", units="J/kg", default=hlf, scale=US%J_kg_to_Q) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 5a37b18604..274a815145 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -72,6 +72,7 @@ module MOM_surface_forcing logical :: use_temperature !< if true, temp & salinity used as state variables logical :: restorebuoy !< if true, use restoring surface buoyancy forcing logical :: adiabatic !< if true, no diapycnal mass fluxes or surface buoyancy forcing + logical :: nonBous !< If true, this run is fully non-Boussinesq logical :: variable_winds !< if true, wind stresses vary with time logical :: variable_buoyforce !< if true, buoyancy forcing varies with time. real :: south_lat !< southern latitude of the domain [degrees_N] or [km] or [m] @@ -252,9 +253,10 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US if (CS%first_call_set_forcing) then ! Allocate memory for the mechanical and thermodynamic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) - call allocate_forcing_type(G, fluxes, ustar=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) + call allocate_forcing_type(G, fluxes, ustar=.not.CS%nonBous, tau_mag=CS%nonBous, & + fix_accum_bug=CS%fix_ustar_gustless_bug) if (trim(CS%buoy_config) /= "NONE") then if ( CS%use_temperature ) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) @@ -529,13 +531,15 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) ! set the friction velocity if (CS%answer_date < 20190101) then - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie forces%tau_mag(i,j) = CS%gust_const + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie forces%ustar(i,j) = sqrt(US%L_to_Z * ((CS%gust_const/CS%Rho0) + & sqrt(0.5*(forces%tauy(i,J-1)*forces%tauy(i,J-1) + forces%tauy(i,J)*forces%tauy(i,J) + & forces%taux(I-1,j)*forces%taux(I-1,j) + forces%taux(I,j)*forces%taux(I,j)))/CS%Rho0) ) - enddo ; enddo + enddo ; enddo ; endif else call stresses_to_ustar(forces, G, US, CS) endif @@ -674,6 +678,9 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) character(len=200) :: filename ! The name of the input file. real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal wind stresses at h-points [R L Z T-2 ~> Pa] real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R L Z T-2 ~> Pa] + real :: ustar_loc(SZI_(G),SZJ_(G)) ! The local value of ustar [Z T-1 ~> m s-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] integer :: time_lev_daily ! The time levels to read for fields with integer :: time_lev_monthly ! daily and monthly cycles. integer :: time_lev ! The time level that is used for a field. @@ -734,16 +741,21 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (.not.read_Ustar) then if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) - forces%ustar(i,j) = sqrt(forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0) - enddo ; enddo + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + forces%ustar(i,j) = sqrt(tau_mag * US%L_to_Z / CS%Rho0) + enddo ; enddo ; endif else - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie forces%tau_mag(i,j) = CS%gust_const + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) - enddo ; enddo + enddo ; enddo ; endif endif endif case ("C") @@ -782,21 +794,28 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) if (.not.read_Ustar) then if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie forces%tau_mag(i,j) = CS%gust(i,j) + & sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) - forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) - enddo ; enddo - else - do j=js,je ; do i=is,ie - forces%tau_mag(i,j) = CS%gust_const + & + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + & sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) - forces%ustar(i,j) = sqrt(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 + forces%ustar(i,j) = sqrt( tau_mag * US%L_to_Z / CS%Rho0 ) + enddo ; enddo ; endif + else + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt(US%L_to_Z * ( (CS%gust_const/CS%Rho0) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2)))/CS%Rho0)) + enddo ; enddo ; endif endif endif case default @@ -805,11 +824,14 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) end select if (read_Ustar) then - call MOM_read_data(filename, CS%Ustar_var, forces%ustar(:,:), & + call MOM_read_data(filename, CS%Ustar_var, ustar_loc(:,:), & G%Domain, timelevel=time_lev, scale=US%m_to_Z*US%T_to_s) - do j=js,je ; do i=is,ie - forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * forces%ustar(i,j)**2 - enddo ; enddo + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * ustar_loc(i,j)**2 + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = ustar_loc(i,j) + enddo ; enddo ; endif endif CS%wind_last_lev = time_lev @@ -833,13 +855,16 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) ! Local variables real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal wind stresses at h-points [R Z L T-2 ~> Pa]. real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R Z L T-2 ~> Pa]. - real :: ustar_tmp(SZI_(G),SZJ_(G)) ! The pre-override value of ustar [Z T-1 ~> m s-1] + real :: ustar_prev(SZI_(G),SZJ_(G)) ! The pre-override value of ustar [Z T-1 ~> m s-1] + real :: ustar_loc(SZI_(G),SZJ_(G)) ! The value of ustar, perhaps altered by data override [Z T-1 ~> m s-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] integer :: i, j call callTree_enter("wind_forcing_by_data_override, MOM_surface_forcing.F90") if (.not.CS%dataOverrideIsInitialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) call data_override_init(G%Domain) CS%dataOverrideIsInitialized = .True. endif @@ -858,26 +883,40 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) if (CS%read_gust_2d) then call data_override(G%Domain, 'gust', CS%gust, day, scale=US%Pa_to_RLZ_T2) - do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (associated(forces%tau_mag)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec forces%tau_mag(i,j) = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust(i,j) - forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) + enddo ; enddo ; endif + do j=G%jsc,G%jec ; do i=G%isc,G%iec + tau_mag = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust(i,j) + ustar_loc(i,j) = sqrt( tau_mag * US%L_to_Z / CS%Rho0 ) enddo ; enddo else + if (associated(forces%tau_mag)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%tau_mag(i,j) = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust_const + ! ustar_loc(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) + enddo ; enddo + endif do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%tau_mag(i,j) = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust_const - ! forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) - forces%ustar(i,j) = sqrt(US%L_to_Z * (sqrt(temp_x(i,j)**2 + temp_y(i,j)**2)/CS%Rho0 + & - CS%gust_const/CS%Rho0)) + ustar_loc(i,j) = sqrt(US%L_to_Z * (sqrt(temp_x(i,j)**2 + temp_y(i,j)**2)/CS%Rho0 + & + CS%gust_const/CS%Rho0)) enddo ; enddo endif ! Give the data override the option to modify the newly calculated forces%ustar. - ustar_tmp(:,:) = forces%ustar(:,:) - call data_override(G%Domain, 'ustar', forces%ustar, day, scale=US%m_to_Z*US%T_to_s) + ustar_prev(:,:) = ustar_loc(:,:) + call data_override(G%Domain, 'ustar', ustar_loc, day, scale=US%m_to_Z*US%T_to_s) + ! Only reset values where data override of ustar has occurred - do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ustar_tmp(i,j) /= forces%ustar(i,j)) then - forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * forces%ustar(i,j)**2 - endif ; enddo ; enddo + if (associated(forces%tau_mag)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ustar_prev(i,j) /= ustar_loc(i,j)) then + forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * ustar_loc(i,j)**2 + endif ; enddo ; enddo + endif + + if (associated(forces%ustar)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = ustar_loc(i,j) + enddo ; enddo ; endif call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) @@ -894,6 +933,8 @@ subroutine stresses_to_ustar(forces, G, US, CS) ! Local variables real :: I_rho ! The inverse of the reference density times a ratio of scaling ! factors [Z L-1 R-1 ~> m3 kg-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -901,19 +942,29 @@ subroutine stresses_to_ustar(forces, G, US, CS) I_rho = US%L_to_Z / CS%Rho0 if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie forces%tau_mag(i,j) = CS%gust(i,j) + & sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) - forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * I_rho ) - enddo ; enddo + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + forces%ustar(i,j) = sqrt( tau_mag * I_rho ) + enddo ; enddo ; endif else - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie forces%tau_mag(i,j) = CS%gust_const + & sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) - forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * I_rho ) - enddo ; enddo + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + forces%ustar(i,j) = sqrt( tau_mag * I_rho ) + enddo ; enddo ; endif endif end subroutine stresses_to_ustar @@ -1528,6 +1579,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! This include declares and sets the variable "version". # include "version_variable.h" real :: flux_const_default ! The unscaled value of FLUXCONST [m day-1] + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=200) :: filename, gust_file ! The name of the gustiness input file. @@ -1550,6 +1603,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + CS%nonBous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & "The directory in which all input files are found.", & default=".") @@ -1812,7 +1873,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "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) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back toward some "//& "specified surface state with a rate given by FLUXCONST.", default=.false.) From e2d244f08323522f52f31c8a1b71e765291314a0 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 4 Oct 2023 16:14:00 -0800 Subject: [PATCH 095/146] We need an extra pass_var for Kv_shear - Only when REMAP_AUXILIARY_VARS is true. --- src/core/MOM.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3013729109..25f4f27ee7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1623,6 +1623,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) + if (associated(CS%visc%Kv_shear)) & + call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, clock=id_clock_pass, halo=1) endif ! Replace the old grid with new one. All remapping must be done by this point in the code. From 08704f8c4f72901bf153221caa77173676692575 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Aug 2023 07:51:17 -0400 Subject: [PATCH 096/146] +*Non-Boussinesq wave_speed calculations Modified the internal wave speed calculation to work in non-Boussinesq mode without any dependencies on the Boussinesq reference density (RHO_0). Many factors of GV%H_to_Z or its inverse are cancelled out in MOM_wave_speed.F90 by working directly in thickness units. The code now uses specific volume derivatives to set the values of g_prime at interfaces when in non-Boussinesq mode, regardless of whether an equation of state is used. This commit also modifies the wave structure calculations in wave_speeds, which includes the use of thickness_to_dz, changes to the units of three arguments to wave_speeds and their counterparts in int_tide_CS, and a number of duplicated calculations of vertical extents mirroring the calculations of thicknesses. Some diagnostic conversion factors were modified accordingly in MOM_internal_tides. This commit involves changing the units of 19 internal variables in wave_speed and 17 internal variables in wave_speeds to use thickness units or other related units. There are 6 new or renamed internal variables in wave_speed and 10 new or renamed variables in wave_speeds. A total 34 thickness rescaling factors or references to GV%Rho0 were cancelled out or replaced. Missing comments describing the units of several real variables were also added. All answers are bitwise identical in Boussinesq mode, but answers do change in non-Boussinesq solutions that depend on the internal wave speed. This commit eliminates the dependencies of the non-Boussinesq wave speed calculations on the Boussinesq reference density. --- src/diagnostics/MOM_wave_speed.F90 | 588 ++++++++++++------ .../lateral/MOM_internal_tides.F90 | 17 +- 2 files changed, 390 insertions(+), 215 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index c2b671f1c6..92c76001c7 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -7,11 +7,12 @@ module MOM_wave_speed use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : log_version use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h, interpolate_column use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs +use MOM_EOS, only : calculate_density_derivs, calculate_specific_vol_derivs implicit none ; private @@ -89,27 +90,28 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real, dimension(SZK_(GV)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [C ~> degC] S_int, & ! Salinity interpolated to interfaces [S ~> ppt] - H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] - H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] - gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. + H_top, & ! The distance of each filtered interface from the ocean surface [H ~> m or kg m-2] + H_bot, & ! The distance of each filtered interface from the bottom [H ~> m or kg m-2] + gprime ! The reduced gravity across each interface [L2 H-1 T-2 ~> m s-2 or m4 s-1 kg-1]. real, dimension(SZK_(GV)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. real, dimension(SZK_(GV),SZI_(G)) :: & - Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] + Hf, & ! Layer thicknesses after very thin layers are combined [H ~> m or kg m-2] Tf, & ! Layer temperatures after very thin layers are combined [C ~> degC] Sf, & ! Layer salinities after very thin layers are combined [S ~> ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] real, dimension(SZK_(GV)) :: & - Hc, & ! A column of layer thicknesses after convective instabilities are removed [Z ~> m] + Hc, & ! A column of layer thicknesses after convective instabilities are removed [H ~> m or kg m-2] Tc, & ! A column of layer temperatures after convective instabilities are removed [C ~> degC] Sc, & ! A column of layer salinities after convective instabilities are removed [S ~> ppt] - Rc, & ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] - Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] - real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] + Rc ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [H-1 ~> m-1 or m2 kg-1] real :: det, ddet ! Determinant of the eigen system and its derivative with lam. Because the ! units of the eigenvalue change with the number of layers and because of the ! dynamic rescaling that is used to keep det in a numerically representable range, @@ -118,18 +120,21 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: lam ! The eigenvalue [T2 L-2 ~> s2 m-2] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s2 m-2] - real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real, dimension(SZI_(G)) :: & - htot, hmin, & ! Thicknesses [Z ~> m] - H_here, & ! A thickness [Z ~> m] - HxT_here, & ! A layer integrated temperature [C Z ~> degC m] - HxS_here, & ! A layer integrated salinity [S Z ~> ppt m] - HxR_here ! A layer integrated density [R Z ~> kg m-2] + htot, hmin, & ! Thicknesses [H ~> m or kg m-2] + H_here, & ! A thickness [H ~> m or kg m-2] + HxT_here, & ! A layer integrated temperature [C H ~> degC m or degC kg m-2] + HxS_here, & ! A layer integrated salinity [S H ~> ppt m or ppt kg m-2] + HxR_here ! A layer integrated density [R H ~> kg m-2 or kg2 m-5] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] - real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: cg1_est ! An initial estimate of the squared first mode speed [L2 T-2 ~> m2 s-2] + real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5] + real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times + ! thicknesses [R-1 H ~> m4 kg-1 or m], negative for stable stratification. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and ! its derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. ! The exact value should not matter for the final result if it is an even power of 2. @@ -148,15 +153,16 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ ! with each iteration. Because of all of the dynamic rescaling of the determinant ! between rows, its units are not easily interpretable, but the ratio of det/ddet ! always has units of [T2 L-2 ~> s2 m-2] - logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: use_EOS ! If true, density or specific volume is calculated from T & S using an equation of state. + logical :: nonBous ! If true, do not make the Boussinesq approximation. logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. logical :: merge ! If true, merge the current layer with the one above. integer :: kc ! The number of layers in the column after merging integer :: i, j, k, k2, itt, is, ie, js, je, nz - real :: hw ! The mean of the adjacent layer thicknesses [Z ~> m] - real :: sum_hc ! The sum of the layer thicknesses [Z ~> m] - real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] - real :: N2min ! A minimum buoyancy frequency, including a slope rescaling factor [L2 Z-2 T-2 ~> s-2] + real :: hw ! The mean of the adjacent layer thicknesses [H ~> m or kg m-2] + real :: sum_hc ! The sum of the layer thicknesses [H ~> m or kg m-2] + real :: gp ! A limited local copy of gprime [L2 H-1 T-2 ~> m s-2 or m4 s-1 kg-1] + real :: N2min ! A minimum buoyancy frequency, including a slope rescaling factor [L2 H-2 T-2 ~> s-2 or m6 kg-2 s-2] logical :: below_mono_N2_frac ! True if an interface is below the fractional depth where N2 should not increase. logical :: below_mono_N2_depth ! True if an interface is below the absolute depth where N2 should not increase. logical :: l_use_ebt_mode, calc_modal_structure @@ -190,9 +196,10 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ enddo ; enddo ; enddo endif - g_Rho0 = GV%g_Earth / GV%Rho0 - ! Simplifying the following could change answers at roundoff. - Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) + g_Rho0 = GV%g_Earth*GV%H_to_Z / GV%Rho0 + H_to_pres = GV%H_to_RZ * GV%g_Earth + ! Note that g_Rho0 = H_to_pres / GV%Rho0**2 + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) use_EOS = associated(tv%eqn_of_state) better_est = CS%better_cg1_est @@ -216,17 +223,17 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. min_h_frac = tol_Hfrac / real(nz) - !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,tv,use_EOS, & + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,tv,use_EOS,nonBous, & !$OMP CS,min_h_frac,calc_modal_structure,l_use_ebt_mode, & !$OMP modal_structure,l_mono_N2_column_fraction,l_mono_N2_depth, & - !$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,cg1_min2, & + !$OMP H_to_pres,cg1,g_Rho0,rescale,I_rescale,cg1_min2, & !$OMP better_est,tol_solve,tol_merge,c2_scale) 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 ! be worked upon one at a time. do i=is,ie ; htot(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo do i=is,ie hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 @@ -234,20 +241,20 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ enddo if (use_EOS) then do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxT_here(i) = (h(i,j,k) * GV%H_to_Z) * tv%T(i,j,k) - HxS_here(i) = (h(i,j,k) * GV%H_to_Z) * tv%S(i,j,k) + H_here(i) = h(i,j,k) + HxT_here(i) = h(i,j,k) * tv%T(i,j,k) + HxS_here(i) = h(i,j,k) * tv%S(i,j,k) else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxT_here(i) = HxT_here(i) + (h(i,j,k) * GV%H_to_Z) * tv%T(i,j,k) - HxS_here(i) = HxS_here(i) + (h(i,j,k) * GV%H_to_Z) * tv%S(i,j,k) + H_here(i) = H_here(i) + h(i,j,k) + HxT_here(i) = HxT_here(i) + h(i,j,k) * tv%T(i,j,k) + HxS_here(i) = HxS_here(i) + h(i,j,k) * tv%S(i,j,k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -255,18 +262,18 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) endif ; enddo - else + else ! .not. (use_EOS) do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + H_here(i) = h(i,j,k) + HxR_here(i) = h(i,j,k)*GV%Rlay(k) else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + H_here(i) = H_here(i) + h(i,j,k) + HxR_here(i) = HxR_here(i) + h(i,j,k)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -279,16 +286,21 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) - pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + pres(K) = pres(K-1) + H_to_pres*Hf(k-1,i) T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) H_top(K) = H_top(K-1) + Hf(k-1,i) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, (/2,kf(i)/) ) + if (nonBous) then + call calculate_specific_vol_derivs(T_int, S_int, pres, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + else + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + endif ! Sum the reduced gravities to find out how small a density difference is negligibly small. - drxh_sum = 0.0 + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. @@ -297,44 +309,81 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif else ! This estimate is problematic in that it goes like 1/nz for a large number of layers, ! but it is an overestimate (as desired) for a small number of layers, by at a factor ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. - do K=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif - else - drxh_sum = 0.0 + else ! .not. (use_EOS) + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then H_top(1) = 0.0 do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif else - do K=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif endif ! use_EOS + if (nonBous) then + ! Note that dSpVxh_sum is negative for stable stratification. + cg1_est = H_to_pres * abs(dSpVxh_sum) + else + cg1_est = g_Rho0 * drxh_sum + endif + ! Find gprime across each internal interface, taking care of convective instabilities by ! merging layers. If the estimated wave speed is too small, simply return zero. - if (g_Rho0 * drxh_sum <= cg1_min2) then + if (cg1_est <= cg1_min2) then cg1(i,j) = 0.0 if (present(modal_structure)) modal_structure(i,j,:) = 0. else @@ -345,9 +394,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ kc = 1 Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) - if (better_est) then + if (better_est .and. nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + elseif (nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + (Hc(kc) + Hf(k,i)) < abs(2.0 * tol_merge * dSpVxh_sum)) else merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) @@ -362,9 +417,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do K2=kc,2,-1 - if (better_est) then + if (better_est .and. nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < abs(tol_merge * dSpVxh_sum) ) + elseif (better_est) then merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + elseif (nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + (Hc(k2) + Hc(k2-1)) < abs(tol_merge * dSpVxh_sum) ) else merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) @@ -381,20 +442,36 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ else ! Add a new layer to the column. kc = kc + 1 - drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + if (nonBous) then + dSpV_dS(Kc) = dSpV_dS(K) ; dSpV_dT(Kc) = dSpV_dT(K) + else + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + endif Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do K=2,kc ! Revisit this if non-Boussinesq. - gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) - enddo - else ! .not.use_EOS + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (dSpV_dT(K)*(Tc(k-1)-Tc(k)) + dSpV_dS(K)*(Sc(k-1)-Sc(k))) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) + enddo + endif + else ! .not. (use_EOS) ! Do the same with density directly... kc = 1 Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) do k=2,kf(i) - if (better_est) then + if (nonBous .and. better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0*tol_merge*drxh_sum) else merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) @@ -407,7 +484,13 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do k2=kc,2,-1 - if (better_est) then + if (nonBous .and. better_est) then + merge = ((Rc(k2) - Rc(k2-1)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(k2-1)*Rc(k2)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rc(k2) - Rc(k2-1)) * (Hc(kc) + Hf(k,i)) < & + (Rc(k2-1)*Rc(k2)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) else merge = ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol_merge*drxh_sum) @@ -426,9 +509,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ endif enddo ! At this point there are kc layers and the gprimes should be positive. - do K=2,kc ! Revisit this if non-Boussinesq. - gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) - enddo + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (Rc(k) - Rc(k-1)) / (Rc(k) * Rc(k-1)) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) + enddo + endif endif ! use_EOS ! Sum the contributions from all of the interfaces to give an over-estimate @@ -453,14 +542,18 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ do k=2,kc hw = 0.5*(Hc(k-1)+Hc(k)) gp = gprime(K) + if (l_mono_N2_column_fraction>0. .or. l_mono_N2_depth>=0.) then - ! Determine whether N2 estimates should not be allowed to increase with depth. + ! Determine whether N2 estimates should not be allowed to increase with depth. if (l_mono_N2_column_fraction>0.) then - !### Change to: (htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) - below_mono_N2_frac = ((G%bathyT(i,j)+G%Z_ref) - GV%H_to_Z*sum_hc < & - l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + below_mono_N2_frac = ((G%bathyT(i,j)+G%Z_ref) - GV%H_to_Z*sum_hc < & + l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) + else + below_mono_N2_frac = (htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) + endif endif - if (l_mono_N2_depth >= 0.) below_mono_N2_depth = (sum_hc > GV%H_to_Z*l_mono_N2_depth) + if (l_mono_N2_depth >= 0.) below_mono_N2_depth = (sum_hc > l_mono_N2_depth) if ( (gp > N2min*hw) .and. (below_mono_N2_frac .or. below_mono_N2_depth) ) then ! Filters out regions where N2 increases with depth, but only in a lower fraction @@ -578,17 +671,13 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ else mode_struct(1:kc)=0. endif - ! Note that remapping_core_h requires that the same units be used - ! for both the source and target grid thicknesses, here [H ~> m or kg m-2]. - do k = 1,kc - Hc_H(k) = GV%Z_to_H * Hc(k) - enddo + if (CS%remap_answer_date < 20190101) then - call remapping_core_h(CS%remapping_CS, kc, Hc_H(:), mode_struct, & + call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & nz, h(i,j,:), modal_structure(i,j,:), & 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) else - call remapping_core_h(CS%remapping_CS, kc, Hc_H(:), mode_struct, & + call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & nz, h(i,j,:), modal_structure(i,j,:), & GV%H_subroundoff, GV%H_subroundoff) endif @@ -666,22 +755,23 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables integer, intent(in) :: nmodes !< Number of modes type(wave_speed_CS), intent(in) :: CS !< Wave speed control struct - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1,nmodes),intent(out) :: w_struct !< Wave Vertical profile [nondim] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV),nmodes),intent(out) :: u_struct !< Wave Horizontal profile [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1,nmodes),intent(out) :: w_struct !< Wave vertical velocity profile [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV),nmodes),intent(out) :: u_struct !< Wave horizontal velocity profile + !! [Z-1 ~> m-1] real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: cn !< Waves speeds [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: u_struct_max !< Maximum of wave horizontal profile - !! [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: u_struct_max !< Maximum of wave horizontal velocity + !! profile [Z-1 ~> m-1] real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: u_struct_bot !< Bottom value of wave horizontal - !! profile [Z-1 ~> m-1] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Nb !< Bottom value of Brunt Vaissalla freqency + !! velocity profile [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Nb !< Bottom value of buoyancy freqency !! [T-1 ~> s-1] - real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_w2 !< depth-integrated - !! vertical profile squared [Z ~> m] - real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_U2 !< depth-integrated - !! horizontal profile squared [Z-1 ~> m-1] - real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_N2w2 !< depth-integrated Brunt Vaissalla - !! frequency times vertical - !! profile squared [Z T-2 ~> m s-2] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_w2 !< depth-integrated vertical velocity + !! profile squared [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_U2 !< depth-integrated horizontal velocity + !! profile squared [H Z-2 ~> m-1 or kg m-4] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_N2w2 !< depth-integrated buoyancy frequency + !! times vertical velocity profile + !! squared [H T-2 ~> m s-2 or kg m-2 s-2] logical, optional, intent(in) :: full_halos !< If true, do the calculation !! over the entire data domain. @@ -689,27 +779,32 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s real, dimension(SZK_(GV)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [C ~> degC] S_int, & ! Salinity interpolated to interfaces [S ~> ppt] - H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] - H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] - gprime, & ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. + H_top, & ! The distance of each filtered interface from the ocean surface [H ~> m or kg m-2] + H_bot, & ! The distance of each filtered interface from the bottom [H ~> m or kg m-2] + gprime, & ! The reduced gravity across each interface [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. N2 ! The buoyancy freqency squared [T-2 ~> s-2] real, dimension(SZK_(GV),SZI_(G)) :: & - Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] + Hf, & ! Layer thicknesses after very thin layers are combined [H ~> m or kg m-2] + dzf, & ! Layer vertical extents after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [C ~> degC] Sf, & ! Layer salinities after very thin layers are combined [S ~> ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] + real, dimension(SZI_(G),SZK_(GV)) :: & + dz_2d ! Height change across layers [Z ~> m] real, dimension(SZK_(GV)) :: & Igl, Igu, & ! The inverse of the reduced gravity across an interface times ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. - Hc, & ! A column of layer thicknesses after convective instabilities are removed [Z ~> m] + Hc, & ! A column of layer thicknesses after convective instabilities are removed [H ~> m or kg m-2] + dzc, & ! A column of layer vertical extents after convective instabilities are removed [Z ~> m] Tc, & ! A column of layer temperatures after convective instabilities are removed [C ~> degC] Sc, & ! A column of layer salinities after convective instabilities are removed [S ~> ppt] - Rc, & ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] - Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] - real :: I_Htot ! The inverse of the total filtered thicknesses [Z-1 ~> m-1] + Rc ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [H-1 ~> m-1 or m2 kg-1] real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and its ! derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. ! The exact value should not matter for the final result if it is an even power of 2. @@ -740,20 +835,24 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s xbl, xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] integer :: numint ! number of widows (intervals) in root searching range integer :: nrootsfound ! number of extra roots found (not including 1st root) - real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real, dimension(SZI_(G)) :: & - htot, hmin, & ! Thicknesses [Z ~> m] - H_here, & ! A thickness [Z ~> m] - HxT_here, & ! A layer integrated temperature [C Z ~> degC m] - HxS_here, & ! A layer integrated salinity [S Z ~> ppt m] - HxR_here ! A layer integrated density [R Z ~> kg m-2] + htot, hmin, & ! Thicknesses [H ~> m or kg m-2] + H_here, & ! A layer thickness [H ~> m or kg m-2] + dz_here, & ! A layer vertical extent [Z ~> m] + HxT_here, & ! A layer integrated temperature [C H ~> degC m or degC kg m-2] + HxS_here, & ! A layer integrated salinity [S H ~> ppt m or ppt kg m-2] + HxR_here ! A layer integrated density [R H ~> kg m-2 or kg2 m-5] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: speed2_min ! minimum mode speed (squared) to consider in root searching [L2 T-2 ~> m2 s-2] real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] + real :: cg1_est ! An initial estimate of the squared first mode speed [L2 T-2 ~> m2 s-2] real, parameter :: reduct_factor = 0.5 ! A factor used in setting speed2_min [nondim] - real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5] + real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times + ! thicknesses [R-1 H ~> m4 kg-1 or m], negative for stable stratification. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 pr m7 s-2 kg-1]. real :: tol_Hfrac ! Layers that together are smaller than this fraction of ! the total water column can be merged for efficiency [nondim]. real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. @@ -762,7 +861,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! when deciding to merge layers in the calculation [nondim] integer :: kf(SZI_(G)) ! The number of active layers after filtering. integer, parameter :: max_itt = 30 - logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. + logical :: use_EOS ! If true, density or specific volume is calculated from T & S using the equation of state. + logical :: nonBous ! If true, do not make the Boussinesq approximation. logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. logical :: merge ! If true, merge the current layer with the one above. integer :: nsub ! number of subintervals used for root finding @@ -777,17 +877,17 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s real, dimension(SZK_(GV)) :: modal_structure_fder !< Normalized model structure [Z-1 ~> m-1] real :: mode_struct(SZK_(GV)+1) ! The mode structure [nondim], but it is also temporarily ! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6. - real :: mode_struct_fder(SZK_(GV)) ! The mode structure 1st derivative [nondim], but it is also temporarily - ! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6. + real :: mode_struct_fder(SZK_(GV)) ! The mode structure 1st derivative [Z-1 ~> m-1], but it is also temporarily + ! in units of [Z-1 L2 T-2 ~> m s-2] after it is modified inside of tdma6. real :: mode_struct_sq(SZK_(GV)+1) ! The square of mode structure [nondim] real :: mode_struct_fder_sq(SZK_(GV)) ! The square of mode structure 1st derivative [Z-2 ~> m-2] real :: ms_min, ms_max ! The minimum and maximum mode structure values returned from tdma6 [L2 T-2 ~> m2 s-2] real :: ms_sq ! The sum of the square of the values returned from tdma6 [L4 T-4 ~> m4 s-4] - real :: w2avg ! A total for renormalization - real, parameter :: a_int = 0.5 ! Integral total for normalization - real :: renorm ! Normalization factor + real :: w2avg ! A total for renormalization [H L4 T-4 ~> m5 s-4 or kg m2 s-4] + real, parameter :: a_int = 0.5 ! Integral total for normalization [nondim] + real :: renorm ! Normalization factor [T2 L-2 ~> s2 m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -798,9 +898,9 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed endif ; endif - g_Rho0 = GV%g_Earth / GV%Rho0 - ! Simplifying the following could change answers at roundoff. - Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) + g_Rho0 = GV%g_Earth * GV%H_to_Z / GV%Rho0 + H_to_pres = GV%H_to_RZ * GV%g_Earth + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) use_EOS = associated(tv%eqn_of_state) if (CS%c1_thresh < 0.0) & @@ -830,59 +930,69 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s w_struct(:,:,:,:) = 0.0 min_h_frac = tol_Hfrac / real(nz) - !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,CS,min_h_frac,use_EOS, & - !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & - !$OMP tol_solve,tol_merge,c2_scale) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,CS,use_EOS,nonBous, & + !$OMP min_h_frac,H_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2, & + !$OMP better_est,tol_solve,tol_merge,c2_scale) 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 ! be worked upon one at a time. do i=is,ie ; htot(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo + + call thickness_to_dz(h, tv, dz_2d, j, G, GV) do i=is,ie - hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 + hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 ; dz_here(i) = 0.0 HxT_here(i) = 0.0 ; HxS_here(i) = 0.0 ; HxR_here(i) = 0.0 enddo if (use_EOS) then do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) + dzf(kf(i),i) = dz_here(i) Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxT_here(i) = (h(i,j,k)*GV%H_to_Z)*tv%T(i,j,k) - HxS_here(i) = (h(i,j,k)*GV%H_to_Z)*tv%S(i,j,k) + H_here(i) = h(i,j,k) + dz_here(i) = dz_2d(i,k) + HxT_here(i) = h(i,j,k)*tv%T(i,j,k) + HxS_here(i) = h(i,j,k)*tv%S(i,j,k) else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxT_here(i) = HxT_here(i) + (h(i,j,k)*GV%H_to_Z)*tv%T(i,j,k) - HxS_here(i) = HxS_here(i) + (h(i,j,k)*GV%H_to_Z)*tv%S(i,j,k) + H_here(i) = H_here(i) + h(i,j,k) + dz_here(i) = dz_here(i) + dz_2d(i,k) + HxT_here(i) = HxT_here(i) + h(i,j,k)*tv%T(i,j,k) + HxS_here(i) = HxS_here(i) + h(i,j,k)*tv%S(i,j,k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then Hf(kf(i),i) = H_here(i) + dzf(kf(i),i) = dz_here(i) Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) endif ; enddo - else + else ! .not. (use_EOS) do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) + dzf(kf(i),i) = dz_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + H_here(i) = h(i,j,k) + dz_here(i) = dz_2d(i,k) + HxR_here(i) = h(i,j,k)*GV%Rlay(k) else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + H_here(i) = H_here(i) + h(i,j,k) + dz_here(i) = dz_here(i) + dz_2d(i,k) + HxR_here(i) = HxR_here(i) + h(i,j,k)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) + dzf(kf(i),i) = dz_here(i) endif ; enddo endif @@ -892,16 +1002,21 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) - pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + pres(K) = pres(K-1) + H_to_pres*Hf(k-1,i) T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) H_top(K) = H_top(K-1) + Hf(k-1,i) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, (/2,kf(i)/) ) + if (nonBous) then + call calculate_specific_vol_derivs(T_int, S_int, pres, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + else + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + endif ! Sum the reduced gravities to find out how small a density difference is negligibly small. - drxh_sum = 0.0 + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. @@ -910,33 +1025,57 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif else ! This estimate is problematic in that it goes like 1/nz for a large number of layers, ! but it is an overestimate (as desired) for a small number of layers, by at a factor ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. - do K=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif - else - drxh_sum = 0.0 + cg1_est = g_Rho0 * drxh_sum + else ! Not use_EOS + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then H_top(1) = 0.0 do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif else do K=2,kf(i) @@ -945,19 +1084,32 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s endif endif + if (nonBous) then + ! Note that dSpVxh_sum is negative for stable stratification. + cg1_est = H_to_pres * abs(dSpVxh_sum) + else + cg1_est = g_Rho0 * drxh_sum + endif + ! Find gprime across each internal interface, taking care of convective ! instabilities by merging layers. - if (g_Rho0 * drxh_sum > cg1_min2) then + if (cg1_est > cg1_min2) then ! Merge layers to eliminate convective instabilities or exceedingly ! small reduced gravities. Merging layers reduces the estimated wave speed by ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. - if (use_EOS) then + if (use_EOS .and. (.not.nonBous)) then kc = 1 - Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) + Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) - if (better_est) then + if (better_est .and. nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + elseif (nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + (Hc(kc) + Hf(k,i)) < abs(2.0 * tol_merge * dSpVxh_sum)) else merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) @@ -967,14 +1119,21 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s I_Hnew = 1.0 / (Hc(kc) + Hf(k,i)) Tc(kc) = (Hc(kc)*Tc(kc) + Hf(k,i)*Tf(k,i)) * I_Hnew Sc(kc) = (Hc(kc)*Sc(kc) + Hf(k,i)*Sf(k,i)) * I_Hnew - Hc(kc) = (Hc(kc) + Hf(k,i)) + Hc(kc) = Hc(kc) + Hf(k,i) + dzc(kc) = dzc(kc) + dzf(k,i) ! Backtrack to remove any convective instabilities above... Note ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do K2=kc,2,-1 - if (better_est) then + if (better_est .and. nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < abs(tol_merge * dSpVxh_sum) ) + elseif (better_est) then merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + elseif (nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + (Hc(k2) + Hc(k2-1)) < abs(tol_merge * dSpVxh_sum) ) else merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) @@ -985,27 +1144,44 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s Tc(kc-1) = (Hc(kc)*Tc(kc) + Hc(kc-1)*Tc(kc-1)) * I_Hnew Sc(kc-1) = (Hc(kc)*Sc(kc) + Hc(kc-1)*Sc(kc-1)) * I_Hnew Hc(kc-1) = Hc(kc) + Hc(kc-1) + dzc(kc-1) = dzc(kc) + dzc(kc-1) kc = kc - 1 else ; exit ; endif enddo else ! Add a new layer to the column. kc = kc + 1 - drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) - Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) + if (nonBous) then + dSpV_dS(Kc) = dSpV_dS(K) ; dSpV_dT(Kc) = dSpV_dT(K) + else + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + endif + Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) ; dzc(kc) = dzf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do K=2,kc ! Revisit this if non-Boussinesq. - gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) - enddo - else ! .not.use_EOS + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (dSpV_dT(K)*(Tc(k-1)-Tc(k)) + dSpV_dS(K)*(Sc(k-1)-Sc(k))) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) + enddo + endif + else ! .not. (use_EOS) ! Do the same with density directly... kc = 1 - Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) + Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Rc(1) = Rf(1,i) do k=2,kf(i) - if (better_est) then - merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + if (nonBous .and. better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0*tol_merge*drxh_sum) else merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) endif @@ -1013,6 +1189,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! Merge this layer with the one above and backtrack. Rc(kc) = (Hc(kc)*Rc(kc) + Hf(k,i)*Rf(k,i)) / (Hc(kc) + Hf(k,i)) Hc(kc) = Hc(kc) + Hf(k,i) + dzc(kc) = dzc(kc) + dzf(k,i) ! Backtrack to remove any convective instabilities above... Note ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. @@ -1026,19 +1203,26 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! Merge the two bottommost layers. At this point kc = k2. Rc(kc-1) = (Hc(kc)*Rc(kc) + Hc(kc-1)*Rc(kc-1)) / (Hc(kc) + Hc(kc-1)) Hc(kc-1) = Hc(kc) + Hc(kc-1) + dzc(kc-1) = dzc(kc) + dzc(kc-1) kc = kc - 1 else ; exit ; endif enddo else ! Add a new layer to the column. kc = kc + 1 - Rc(kc) = Rf(k,i) ; Hc(kc) = Hf(k,i) + Rc(kc) = Rf(k,i) ; Hc(kc) = Hf(k,i) ; dzc(kc) = dzf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do K=2,kc ! Revisit this if non-Boussinesq. - gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) - enddo + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (Rc(k) - Rc(k-1)) / (Rc(k) * Rc(k-1)) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) + enddo + endif endif ! use_EOS !-----------------NOW FIND WAVE SPEEDS--------------------------------------- @@ -1063,8 +1247,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s N2(:) = 0. do K=2,kc - Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) - N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) + Igl(K) = 1.0 / (gprime(K)*Hc(k)) ; Igu(K) = 1.0 / (gprime(K)*Hc(k-1)) + if (nonBous) then + N2(K) = 2.0*US%L_to_Z**2*gprime(K) * (Hc(k) + Hc(k-1)) / & ! Units are [T-2 ~> s-2] + (dzc(k) + dzc(k-1))**2 + else + N2(K) = 2.0*US%L_to_Z**2*GV%Z_to_H*gprime(K) / (dzc(k) + dzc(k-1)) ! Units are [T-2 ~> s-2] + endif if (better_est) then speed2_tot = speed2_tot + gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) else @@ -1113,12 +1302,11 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! renormalization of the integral of the profile w2avg = 0.0 do k=1,kc - w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) ![Z L4 T-4] + w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) ! [H L4 T-4] enddo renorm = sqrt(htot(i)*a_int/w2avg) ! [T2 L-2] do K=1,kc+1 ; mode_struct(K) = renorm * mode_struct(K) ; enddo ! after renorm, mode_struct is again [nondim] - if (abs(dlam) < tol_solve*lam_1) exit enddo @@ -1131,7 +1319,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! vertical derivative of w at interfaces lives on the layer points do k=1,kc - mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / Hc(k) + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / dzc(k) enddo ! boundary condition for derivative is no-gradient @@ -1163,18 +1351,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s mode_struct_sq(K+1)*N2(K+1)) * Hc(k) enddo - ! Note that remapping_core_h requires that the same units be used - ! for both the source and target grid thicknesses, here [H ~> m or kg m-2]. - do k = 1,kc - Hc_H(k) = GV%Z_to_H * Hc(k) - enddo - ! for w (diag) interpolate onto all interfaces - call interpolate_column(kc, Hc_H(1:kc), mode_struct(1:kc+1), & + call interpolate_column(kc, Hc(1:kc), mode_struct(1:kc+1), & nz, h(i,j,:), modal_structure(:), .false.) ! for u (remap) onto all layers - call remapping_core_h(CS%remapping_CS, kc, Hc_H(1:kc), mode_struct_fder(1:kc), & + call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & nz, h(i,j,:), modal_structure_fder(:), & GV%H_subroundoff, GV%H_subroundoff) @@ -1313,7 +1495,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! derivative of vertical profile (i.e. dw/dz) is evaluated at the layer point do k=1,kc - mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / Hc(k) + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / dzc(k) enddo ! boundary condition for 1st derivative is no-gradient @@ -1345,18 +1527,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s mode_struct_sq(K+1)*N2(K+1)) * Hc(k) enddo - ! Note that remapping_core_h requires that the same units be used - ! for both the source and target grid thicknesses, here [H ~> m or kg m-2]. - do k = 1,kc - Hc_H(k) = GV%Z_to_H * Hc(k) - enddo - ! for w (diag) interpolate onto all interfaces - call interpolate_column(kc, Hc_H(1:kc), mode_struct(1:kc+1), & + call interpolate_column(kc, Hc(1:kc), mode_struct(1:kc+1), & nz, h(i,j,:), modal_structure(:), .false.) ! for u (remap) onto all layers - call remapping_core_h(CS%remapping_CS, kc, Hc_H(1:kc), mode_struct_fder(1:kc), & + call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & nz, h(i,j,:), modal_structure_fder(:), & GV%H_subroundoff, GV%H_subroundoff) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 83910e6690..7d1ec38fba 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -110,11 +110,11 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:) :: u_struct_bot !< Bottom value of u_struct, !! for each mode [Z-1 ~> m-1] real, allocatable, dimension(:,:,:) :: int_w2 !< Vertical integral of w_struct squared, - !! for each mode [Z ~> m] + !! for each mode [H ~> m or kg m-2] real, allocatable, dimension(:,:,:) :: int_U2 !< Vertical integral of u_struct squared, - !! for each mode [Z-1 ~> m-1] + !! for each mode [H Z-2 ~> m-1 or kg m-4] real, allocatable, dimension(:,:,:) :: int_N2w2 !< Depth-integrated Brunt Vaissalla freqency times - !! vertical profile squared, for each mode [Z T-2 ~> m s-2] + !! vertical profile squared, for each mode [H T-2 ~> m s-2 or kg m-2 s-2] real :: q_itides !< fraction of local dissipation [nondim] real :: En_sum !< global sum of energy for use in debugging, in MKS units [J] type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. @@ -529,9 +529,9 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Back-calculate amplitude from energy equation if ( (G%mask2dT(i,j) > 0.5) .and. (freq2*Kmag2 > 0.0)) then ! Units here are [R Z ~> kg m-2] - KE_term = 0.25*GV%Rho0*( ((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m) + & + KE_term = 0.25*GV%H_to_RZ*( ((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m) + & CS%int_w2(i,j,m) ) - PE_term = 0.25*GV%Rho0*( CS%int_N2w2(i,j,m) / freq2 ) + PE_term = 0.25*GV%H_to_RZ*( CS%int_N2w2(i,j,m) / freq2 ) if (KE_term + PE_term > 0.0) then W0 = sqrt( tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) @@ -2820,7 +2820,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) enddo - ! Register maps of reflection parameters CS%id_refl_ang = register_diag_field('ocean_model', 'refl_angle', diag%axesT1, & Time, 'Local angle of coastline/ridge/shelf with respect to equator', 'rad') @@ -2971,19 +2970,19 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_int_w2","_mode",i1)') m write(var_descript, '("integral of w2 for mode ",i1)') m CS%id_int_w2_mode(m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'm', conversion=US%Z_to_m) + diag%axesT1, Time, var_descript, 'm', conversion=GV%H_to_m) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) write(var_name, '("Itide_int_U2","_mode",i1)') m write(var_descript, '("integral of U2 for mode ",i1)') m CS%id_int_U2_mode(m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'm-1', conversion=US%m_to_L) + diag%axesT1, Time, var_descript, 'm-1', conversion=US%m_to_Z*GV%H_to_Z) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) write(var_name, '("Itide_int_N2w2","_mode",i1)') m write(var_descript, '("integral of N2w2 for mode ",i1)') m CS%id_int_N2w2_mode(m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'm s-2', conversion=US%Z_to_m*US%s_to_T**2) + diag%axesT1, Time, var_descript, 'm s-2', conversion=GV%H_to_m*US%s_to_T**2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) enddo From 2047676a38e1caa9e99b07837395714446fc7fc1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 28 Sep 2023 08:00:41 -0400 Subject: [PATCH 097/146] +*Add halo_size argument to wave_speeds Replace the optional full_halos logical argument to wave_speed and wave_speeds with an optional halo_size integer argument, following the pattern used elsewhere in the MOM6 code, with a similar change to itidal_lowmode_loss. This halo_size argument is used in the call to thickness_to_dz in wave_speeds, and the call to wave_speeds in propagate_int_tides was modified accordingly. In addition, the loop bounds in the MOM_internal_tides code were modified to avoid excessive calculations over the full data domain, some of which would use uninitialized variables. Also modified the logic determining the value of diabatic_halo as returned by extract_diabatic_member to account for the wider halos that are needed when the internal tide code is used. This commit changes the interfaces publicly visible routines and it changes answers in cases when the internal_tides are used by doing calculations of the wave speeds in halo points that are used in that code. --- src/diagnostics/MOM_wave_speed.F90 | 38 +++--- .../lateral/MOM_internal_tides.F90 | 114 ++++++++++-------- .../vertical/MOM_diabatic_driver.F90 | 8 +- 3 files changed, 89 insertions(+), 71 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 92c76001c7..59dbfc184e 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -63,7 +63,7 @@ module MOM_wave_speed contains !> Calculates the wave speed of the first baroclinic mode. -subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_N2_column_fraction, & +subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N2_column_fraction, & mono_N2_depth, modal_structure) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -73,8 +73,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [L T-1 ~> m s-1] type(wave_speed_CS), intent(in) :: CS !< Wave speed control struct - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire computational domain. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate wave speeds logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction @@ -158,7 +158,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. logical :: merge ! If true, merge the current layer with the one above. integer :: kc ! The number of layers in the column after merging - integer :: i, j, k, k2, itt, is, ie, js, je, nz + integer :: i, j, k, k2, itt, is, ie, js, je, nz, halo real :: hw ! The mean of the adjacent layer thicknesses [H ~> m or kg m-2] real :: sum_hc ! The sum of the layer thicknesses [H ~> m or kg m-2] real :: gp ! A limited local copy of gprime [L2 H-1 T-2 ~> m s-2 or m4 s-1 kg-1] @@ -173,14 +173,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: ms_min, ms_max ! The minimum and maximum mode structure values returned from tdma6 [L2 T-2 ~> m2 s-2] real :: ms_sq ! The sum of the square of the values returned from tdma6 [L4 T-4 ~> m4 s-4] - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; halo = 0 if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speed: "// & "Module must be initialized before it is used.") - if (present(full_halos)) then ; if (full_halos) then - is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed - endif ; endif + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif l_use_ebt_mode = CS%use_ebt_mode if (present(use_ebt_mode)) l_use_ebt_mode = use_ebt_mode @@ -747,7 +748,7 @@ end subroutine tdma6 !> Calculates the wave speeds for the first few barolinic modes. subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_struct_max, u_struct_bot, Nb, int_w2, & - int_U2, int_N2w2, full_halos) + int_U2, int_N2w2, halo_size) 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 @@ -772,8 +773,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_N2w2 !< depth-integrated buoyancy frequency !! times vertical velocity profile !! squared [H T-2 ~> m s-2 or kg m-2 s-2] - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire data domain. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate wave speeds ! Local variables real, dimension(SZK_(GV)+1) :: & @@ -872,7 +873,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s logical :: sub_rootfound ! if true, subdivision has located root integer :: kc ! The number of layers in the column after merging integer :: sub, sub_it - integer :: i, j, k, k2, itt, is, ie, js, je, nz, iint, m + integer :: i, j, k, k2, itt, is, ie, js, je, nz, iint, m, halo real, dimension(SZK_(GV)+1) :: modal_structure !< Normalized model structure [nondim] real, dimension(SZK_(GV)) :: modal_structure_fder !< Normalized model structure [Z-1 ~> m-1] real :: mode_struct(SZK_(GV)+1) ! The mode structure [nondim], but it is also temporarily @@ -889,14 +890,15 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s real, parameter :: a_int = 0.5 ! Integral total for normalization [nondim] real :: renorm ! Normalization factor [T2 L-2 ~> s2 m-2] - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; halo = 0 if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speeds: "// & "Module must be initialized before it is used.") - if (present(full_halos)) then ; if (full_halos) then - is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed - endif ; endif + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif g_Rho0 = GV%g_Earth * GV%H_to_Z / GV%Rho0 H_to_pres = GV%H_to_RZ * GV%g_Earth @@ -940,7 +942,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s do i=is,ie ; htot(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo - call thickness_to_dz(h, tv, dz_2d, j, G, GV) + call thickness_to_dz(h, tv, dz_2d, j, G, GV, halo_size=halo) do i=is,ie hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 ; dz_here(i) = 0.0 @@ -1097,7 +1099,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! Merge layers to eliminate convective instabilities or exceedingly ! small reduced gravities. Merging layers reduces the estimated wave speed by ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. - if (use_EOS .and. (.not.nonBous)) then + if (use_EOS) then kc = 1 Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 7d1ec38fba..172d2459d5 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -259,6 +259,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] character(len=160) :: mesg ! The text of an error message + integer :: En_halo_ij_stencil ! The halo size needed for energy advection integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) type(group_pass_type), save :: pass_test, pass_En @@ -314,13 +315,16 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, else call wave_speeds(h, tv, G, GV, US, CS%nMode, cn, CS%wave_speed, & CS%w_struct, CS%u_struct, CS%u_struct_max, CS%u_struct_bot, & - Nb, CS%int_w2, CS%int_U2, CS%int_N2w2, full_halos=.true.) + Nb, CS%int_w2, CS%int_U2, CS%int_N2w2, halo_size=2) + ! The value of halo_size above would have to be larger if there were + ! not a halo update between the calls to propagate_x and propagate_y. + ! It can be 1 point smaller if teleport is not used. endif ! Set the wave speeds for the modes, using cg(n) ~ cg(1)/n.********************** ! This is wrong, of course, but it works reasonably in some cases. ! Uncomment if wave_speed is not used to calculate the true values (BDM). - !do m=1,CS%nMode ; do j=jsd,jed ; do i=isd,ied + !do m=1,CS%nMode ; do j=js-2,je+2 ; do i=is-2,ie+2 ! cn(i,j,m) = cn(i,j,1) / real(m) !enddo ; enddo ; enddo @@ -362,6 +366,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & G, US, CS%nAngle, CS%use_PPMang) enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -381,8 +386,13 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call complete_group_pass(pass_test, G%domain) + ! Set the halo size to work on, using similar logic to that used in propagate. This may need + ! to be adjusted depending on the advection scheme and whether teleport is used. + if (CS%upwind_1st) then ; En_halo_ij_stencil = 2 + else ; En_halo_ij_stencil = 3 ; endif + ! Rotate points in the halos as necessary. - call correct_halo_rotation(CS%En, test, G, CS%nAngle) + call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) ! Propagate the waves. do m=1,CS%nMode ; do fr=1,CS%Nfreq @@ -414,6 +424,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & G, US, CS%NAngle, CS%use_PPMang) enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -421,7 +432,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) + 'En=', CS%En(i,j,a,fr,m) call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) CS%En(i,j,a,fr,m) = 0.0 ! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") @@ -436,7 +447,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, tot_En(:,:) = 0.0 tot_En_mode(:,:,:,:) = 0.0 do m=1,CS%nMode ; do fr=1,CS%Nfreq - do j=jsd,jed ; do i=isd,ied ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie ; do a=1,CS%nAngle tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) tot_En_mode(i,j,fr,m) = tot_En_mode(i,j,fr,m) + CS%En(i,j,a,fr,m) enddo ; enddo ; enddo @@ -445,7 +456,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Extract the energy for mixing due to misc. processes (background leakage)------ if (CS%apply_background_drag) then - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [R Z3 T-3 ~> W m-2] @@ -468,25 +479,25 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then - do j=jsd,jed ; do i=isd,ied ; htot(i,j) = 0.0 ; enddo ; enddo - do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie ; htot(i,j) = 0.0 ; enddo ; enddo + do k=1,GV%ke ; do j=js,je ; do i=is,ie htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo if (GV%Boussinesq) then ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. - do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & tot_En(i,j) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here enddo ; enddo else - do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) drag_scale(i,j) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + tot_En(i,j) * I_mass)) enddo ; enddo endif - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j) ! loss rate @@ -515,7 +526,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, do m=1,CS%nMode ; do fr=1,CS%Nfreq ! compute near-bottom and max horizontal baroclinic velocity values at each point - do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging ! Calculate wavenumber magnitude @@ -557,7 +568,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, if (CS%apply_wave_drag) then ! Calculate loss rate and apply loss over the time step call itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, CS%En, CS%TKE_itidal_loss_fixed, & - CS%TKE_itidal_loss, dt, full_halos=.false.) + CS%TKE_itidal_loss, dt, halo_size=0) endif ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -644,7 +655,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! loss from residual of reflection/transmission coefficients if (CS%apply_residual_drag) then - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! implicit form !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%TKE_residual_loss(i,j,a,fr,m) / & ! (CS%En(i,j,a,fr,m) + en_subRO)) @@ -863,7 +874,7 @@ end subroutine sum_En !> Calculates the energy lost from the propagating internal tide due to !! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). -subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) +subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixed, TKE_loss, dt, halo_size) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -884,10 +895,9 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe intent(out) :: TKE_loss !< Energy loss rate [R Z3 T-3 ~> W m-2] !! (q*rho*kappa*h^2*N*U^2). real, intent(in) :: dt !< Time increment [T ~> s]. - logical,optional, intent(in) :: full_halos !< If true, do the calculation over the - !! entire computational domain. + integer, optional, intent(in) :: halo_size !< The halo size over which to do the calculations ! Local variables - integer :: j,i,m,fr,a, is, ie, js, je + integer :: j, i, m, fr, a, is, ie, js, je, halo real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] real :: frac_per_sector ! fraction of energy in each wedge [nondim] @@ -901,9 +911,10 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe q_itides = CS%q_itides En_negl = 1e-30*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2 - if (present(full_halos)) then ; if (full_halos) then - is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed - endif ; endif + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif do j=js,je ; do i=is,ie ; do m=1,CS%nMode ; do fr=1,CS%nFreq @@ -931,7 +942,9 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe enddo else ! no loss if no energy - TKE_loss(i,j,:,fr,m) = 0.0 + do a=1,CS%nAngle + TKE_loss(i,j,a,fr,m) = 0.0 + enddo endif ! Update energy remaining (this is the old explicit calc) @@ -2099,7 +2112,7 @@ end subroutine teleport !> Rotates points in the halos where required to accommodate !! changes in grid orientation, such as at the tripolar fold. -subroutine correct_halo_rotation(En, test, G, NAngle) +subroutine correct_halo_rotation(En, test, G, NAngle, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(:,:,:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a !! function of space, angular orientation, frequency, @@ -2110,18 +2123,19 @@ subroutine correct_halo_rotation(En, test, G, NAngle) !! wave energies in the halo region to be corrected [nondim]. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. + integer, intent(in) :: halo !< The halo size over which to do the calculations ! Local variables real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density ! in a frequency band and mode [R Z3 T-2 ~> J m-2]. integer, dimension(G%isd:G%ied) :: a_shift integer :: i_first, i_last, a_new - integer :: a, i, j, isd, ied, jsd, jed, m, fr + integer :: a, i, j, ish, ieh, jsh, jeh, m, fr character(len=160) :: mesg ! The text of an error message - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + ish = G%isc-halo ; ieh = G%iec+halo ; jsh = G%jsc-halo ; jeh = G%jec+halo - do j=jsd,jed - i_first = ied+1 ; i_last = isd-1 - do i=isd,ied + do j=jsh,jeh + i_first = ieh+1 ; i_last = ish-1 + do i=ish,ieh a_shift(i) = 0 if (test(i,j,1) /= 1.0) then if (i 0.0) then - CS%refl_pref_logical(i,j) = .true. - endif - enddo - enddo + do j=jsd,jed ; do i=isd,ied + ! flag cells with partial reflection + if ((CS%refl_angle(i,j) /= CS%nullangle) .and. & + (CS%refl_pref(i,j) < 1.0) .and. (CS%refl_pref(i,j) > 0.0)) then + CS%refl_pref_logical(i,j) = .true. + endif + enddo ; enddo ! Read in double-reflective (ridge) tags from file call get_param(param_file, mdl, "REFL_DBL_FILE", refl_dbl_file, & @@ -2776,11 +2788,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (trim(refl_dbl_file) /= '' ) call MOM_error(FATAL, & "REFL_DBL_FILE: "//trim(filename)//" not found") endif - call pass_var(ridge_temp,G%domain) + call pass_var(ridge_temp, G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed), source=.false.) - do i=isd,ied ; do j=jsd,jed - if (ridge_temp(i,j) == 1) then; CS%refl_dbl(i,j) = .true. - else ; CS%refl_dbl(i,j) = .false. ; endif + do j=jsd,jed ; do i=isd,ied + CS%refl_dbl(i,j) = (ridge_temp(i,j) == 1) enddo ; enddo ! Read in the transmission coefficient and infer the residual @@ -2797,17 +2808,16 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "TRANS_FILE: "//trim(filename)//" not found") endif - call pass_var(CS%trans,G%domain) + call pass_var(CS%trans, G%domain) + ! residual allocate(CS%residual(isd:ied,jsd:jed), source=0.0) - do j=jsd,jed - do i=isd,ied - if (CS%refl_pref_logical(i,j)) then - CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) - endif - enddo - enddo - call pass_var(CS%residual,G%domain) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) + endif + enddo ; enddo + call pass_var(CS%residual, G%domain) CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1ccd6a7fb2..5b89c8c726 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -159,6 +159,9 @@ module MOM_diabatic_driver !! evaporated in one time-step [nondim]. integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that !! must be valid for the diffusivity calculations. + integer :: halo_diabatic = 0 !< The temperature, salinity, specific volume and thickness + !! halo size that must be valid for the diabatic calculations, + !! including vertical mixing and internal tide propagation. logical :: useKPP = .false. !< use CVMix/KPP diffusivities and non-local transport logical :: KPPisPassive !< If true, KPP is in passive mode, not changing answers. logical :: debug !< If true, write verbose checksums for debugging purposes. @@ -2661,7 +2664,7 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, ! Constants within diabatic_CS if (present(evap_CFL_limit)) evap_CFL_limit = CS%evap_CFL_limit if (present(minimum_forcing_depth)) minimum_forcing_depth = CS%minimum_forcing_depth - if (present(diabatic_halo)) diabatic_halo = CS%halo_TS_diff + if (present(diabatic_halo)) diabatic_halo = CS%halo_diabatic if (present(use_KPP)) use_KPP = CS%use_KPP end subroutine extract_diabatic_member @@ -3513,6 +3516,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di halo_TS=CS%halo_TS_diff, double_diffuse=CS%double_diffuse, & physical_OBL_scheme=physical_OBL_scheme) + CS%halo_diabatic = CS%halo_TS_diff + if (CS%use_int_tides) CS%halo_diabatic = max(CS%halo_TS_diff, 2) + if (CS%useKPP .and. (CS%double_diffuse .and. .not.CS%use_CVMix_ddiff)) & call MOM_error(FATAL, 'diabatic_driver_init: DOUBLE_DIFFUSION (old method) does not work '//& 'with KPP. Please set DOUBLE_DIFFUSION=False and USE_CVMIX_DDIFF=True.') From 6756b4834dfe175aaf8b9d3521a5713c9b04734f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 2 Oct 2023 22:36:08 -0400 Subject: [PATCH 098/146] makedep: Module dependency in nested includes Nested includes are tracked for the purpose of include flags (-I), but not with respect to the content within those files. This patch tracks the module usage statements (`use ...`) inside of any include files and adds them to the Makefile rules of the top-level file. This was implemented within the `nested_inc` function by adding a new argument. --- ac/makedep | 35 +++++++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/ac/makedep b/ac/makedep index 502250020b..9da68aa6e6 100755 --- a/ac/makedep +++ b/ac/makedep @@ -150,7 +150,10 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, dep for pair in zip(found_mods, found_objs) for dep in pair ] missing_mods = [m for m in o2uses[o] if m not in all_modules] - incs = nested_inc(o2h[o] + o2inc[o], f2F) + + incs, inc_used = nested_inc(o2h[o] + o2inc[o], f2F) + inc_mods = [u for u in inc_used if u not in found_mods and u in all_modules] + incdeps = sorted(set([f2F[f] for f in incs if f in f2F])) incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) if debug: @@ -167,7 +170,7 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, print("# program:", ' '.join(o2prg[o]), file=file) if o2mods[o]: print(' '.join(o2mods[o])+':', o, file=file) - print(o + ':', o2F90[o], ' '.join(incdeps+found_deps), file=file) + print(o + ':', o2F90[o], ' '.join(inc_mods + incdeps + found_deps), file=file) print('\t'+fc_rule, ' '.join(incargs), file=file) # Write rule for each object from C @@ -243,10 +246,18 @@ def link_obj(obj, o2uses, mod2o, all_modules): def nested_inc(inc_files, f2F): """List of all files included by "inc_files", either by #include or F90 include.""" + hlst = [] + used_mods = set() + def recur(hfile): if hfile not in f2F.keys(): return - _, _, cpp, inc, _, _ = scan_fortran_file(f2F[hfile]) + + _, used, cpp, inc, _, _ = scan_fortran_file(f2F[hfile]) + + # Record any module updates inside of include files + used_mods.update(used) + if len(cpp) + len(inc) > 0: for h in cpp+inc: if h not in hlst and h in f2F.keys(): @@ -254,10 +265,11 @@ def nested_inc(inc_files, f2F): hlst.append(h) return return - hlst = [] + for h in inc_files: recur(h) - return inc_files + sorted(set(hlst)) + + return inc_files + sorted(set(hlst)), used_mods def scan_fortran_file(src_file): @@ -268,8 +280,10 @@ def scan_fortran_file(src_file): lines = file.readlines() external_namespace = True + # True if we are in the external (i.e. global) namespace file_has_externals = False + # True if the file contains any external objects for line in lines: match = re_module.match(line.lower()) @@ -321,17 +335,18 @@ def object_file(src_file): def find_files(src_dirs): """Return sorted list of all source files starting from each directory in the list "src_dirs".""" + + # TODO: Make this a user-defined argument + extensions = ('.f90', '.f', '.c', '.inc', '.h', '.fh') + files = [] + for path in src_dirs: if not os.path.isdir(path): raise ValueError("Directory '{}' was not found".format(path)) for p, d, f in os.walk(os.path.normpath(path), followlinks=True): for file in f: - # TODO: use any() - if (file.endswith('.F90') or file.endswith('.f90') - or file.endswith('.f') or file.endswith('.F') - or file.endswith('.h') or file.endswith('.inc') - or file.endswith('.c') or file.endswith('.H')): + if any(file.lower().endswith(ext) for ext in extensions): files.append(p+'/'+file) return sorted(set(files)) From 6d684598e44842cd4c425917afa0edcba046ebac Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 30 Sep 2023 04:12:17 -0400 Subject: [PATCH 099/146] +(*)Non-Boussinesq default for Z_INIT_REMAP_GENERAL Changed the default value of Z_INIT_REMAP_GENERAL to true for fully non-Boussinesq configurations. All existing fully non-Boussinesq cases that use INIT_LAYERS_FROM_Z_FILE = True use this setting, and it is likely that such cases will not work at all if this is false. This change reduces the parameters that need to be changed to go between equivalent Boussinesq and non-Boussinesq configurations to just BOUSSINESQ and SEMI_BOUSSINESQ. The previous default (false) is being retained for any Boussinesq or semi-Bousssinesq cases so that all answers and output are bitwise identical in those cases, but by default some non-Boussinesq solutions change answers, and there are changes to the MOM_parameter_doc files for those non-Boussinesq cases. --- src/initialization/MOM_state_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index fc676781bc..69d59961ec 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2558,7 +2558,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just call get_param(PF, mdl, "Z_INIT_REMAP_GENERAL", remap_general, & "If false, only initializes to z* coordinates. "//& "If true, allows initialization directly to general coordinates.", & - default=.false., do_not_log=just_read) + default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq) , do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_FULL_COLUMN", remap_full_column, & "If false, only reconstructs profiles for valid data points. "//& "If true, inserts vanished layers below the valid data.", & From 13f26036e7849bd435500f00959c45989fb82c38 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 7 Aug 2023 10:27:02 -0400 Subject: [PATCH 100/146] +*Non-Boussinesq revision of lateral_mixing_coeffs This commit revises lateral_mixing_coeffs to work in an appropriate mixture of thickness and vertical extent variables to avoid any dependence on the Boussinesq reference density in non-Boussinesq mode, while retaining the previous answers in Boussinesq mode. This commit adds the new runtime parameter FULL_DEPTH_EADY_GROWTH_RATE to indicate that the denominator of an Eady growth rate calculation should be based on the full depth of the water column, rather than the nominal depth of the bathymetry. The new option is only the default for fully non-Boussinesq cases. A primordial horizontal indexing bug was corrected in the v-direction slope calculation. Because it only applies for very shallow bathymetry, does not appear to impact any existing test cases and went undetected for at least 12 years, it was corrected directly rather than wrapping in another new runtime flag. However, this bug is being retained for now in a comment to help with review and debugging if the answers should change unexpectedly in some yet-to-be identified configuration. Two debugging checksums were added for the output variables calculated in calc_resoln_function. The case of some indices was corrected to follow the MOM6 soft convention using case to indicate the staggering position of variables. The previously incorrect units of one comment were also fixed. There is a new logical element in the VarMix_CS type. To accommodate these changes there are three new internal variables in calc_slope_functions_using_just_e. A total of 9 GV%H_to_Z conversion factors were eliminated with this commit. N2 is no longer calculated separately in calc_slope_functions_using_just_e, but this code is left in a comment as it may be instructive. This commit involved changing the units of one internal variable in calc_QG_Leith_viscosity to use inverse thickness units (as its descriptive comment already indicated). There are already known problems with calc_QG_Leith_viscosity as documented with a fatal error; this will be addressed in a subsequent commit. All answers are bitwise identical in the existing MOM6-examples test suite, but they will change when fully non-Boussinesq, and there is a new entry in some MOM_parameter_doc files. --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 148 ++++++++++++------ 1 file changed, 103 insertions(+), 45 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 1bf416b00a..4f1dbb89ac 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -10,7 +10,7 @@ module MOM_lateral_mixing_coeffs 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_interface_heights, only : find_eta, thickness_to_dz use MOM_isopycnal_slopes, only : calc_isoneutral_slopes use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type @@ -59,16 +59,21 @@ module MOM_lateral_mixing_coeffs !! This parameter is set depending on other parameters. logical :: calculate_depth_fns !< If true, calculate all the depth factors. !! This parameter is set depending on other parameters. - logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. + logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rates. !! This parameter is set depending on other parameters. logical :: use_stanley_iso !< If true, use Stanley parameterization in MOM_isopycnal_slopes logical :: use_simpler_Eady_growth_rate !< If true, use a simpler method to calculate the !! Eady growth rate that avoids division by layer thickness. !! This parameter is set depending on other parameters. + logical :: full_depth_Eady_growth_rate !< If true, calculate the Eady growth rate based on an + !! average that includes contributions from sea-level changes + !! in its denominator, rather than just the nominal depth of + !! the bathymetry. This only applies when using the model + !! interface heights as a proxy for isopycnal slopes. real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or !! incropped interfaces for the Eady growth rate calc [Z ~> m] real :: h_min_N2 !< The minimum vertical distance to use in the denominator of the - !! bouyancy frequency used in the slope calculation [Z ~> m] + !! bouyancy frequency used in the slope calculation [H ~> m or kg m-2] real, allocatable :: SN_u(:,:) !< S*N at u-points [T-1 ~> s-1] real, allocatable :: SN_v(:,:) !< S*N at v-points [T-1 ~> s-1] @@ -449,6 +454,12 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (CS%id_Res_fn > 0) call post_data(CS%id_Res_fn, CS%Res_fn_h, CS%diag) endif + if (CS%debug) then + call hchksum(CS%cg1, "calc_resoln_fn cg1", G%HI, haloshift=1, scale=US%L_T_to_m_s) + call uvchksum("Res_fn_[uv]", CS%Res_fn_u, CS%Res_fn_v, G%HI, haloshift=0, & + scale=1.0, scalar_pair=.true.) + endif + 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. @@ -684,7 +695,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, integer :: i, j, k, l_seg logical :: crop - dz_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff D_scale = CS%Eady_GR_D_scale if (D_scale<=0.) D_scale = 64.*GV%max_depth ! 0 means use full depth so choose something big r_crp_dist = 1. / max( dz_neglect, CS%cropping_distance ) @@ -818,12 +829,16 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface position [Z ~> m] + ! type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables logical, intent(in) :: calculate_slopes !< If true, calculate slopes !! internally otherwise use slopes stored in CS ! Local variables real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [Z L-1 ~> nondim] (for diagnostics) real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [Z L-1 ~> nondim] (for diagnostics) + real :: dz_tot(SZI_(G),SZJ_(G)) ! The total thickness of the water columns [Z ~> m] + ! real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The vertical distance across each layer [Z ~> m] real :: H_cutoff ! Local estimate of a minimum thickness for masking [H ~> m or kg m-2] + real :: dZ_cutoff ! A minimum water column depth for masking [H ~> m or kg m-2] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] @@ -834,6 +849,8 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop ! the buoyancy frequency squared at u-points [Z T-2 ~> m s-2] real :: S2N2_v_local(SZI_(G),SZJB_(G),SZK_(GV)) ! The depth integral of the slope times ! the buoyancy frequency squared at v-points [Z T-2 ~> m s-2] + logical :: use_dztot ! If true, use the total water column thickness rather than the + ! bathymetric depth for certain calculations. integer :: is, ie, js, je, nz integer :: i, j, k integer :: l_seg @@ -851,6 +868,25 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop h_neglect = GV%H_subroundoff H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) + dZ_cutoff = real(2*nz) * (GV%Angstrom_Z + GV%dz_subroundoff) + + use_dztot = CS%full_depth_Eady_growth_rate ! .or. .not.(GV%Boussinesq or GV%semi_Boussinesq) + + if (use_dztot) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + dz_tot(i,j) = e(i,j,1) - e(i,j,nz+1) + enddo ; enddo + ! The following mathematically equivalent expression is more expensive but is less + ! sensitive to roundoff for large Z_ref: + ! call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + ! do j=js-1,je+1 + ! do i=is-1,ie+1 ; dz_tot(i,j) = 0.0 ; enddo + ! do k=1,nz ; do i=is-1,ie+1 + ! dz_tot(i,j) = dz_tot(i,j) + dz(i,j,k) + ! enddo ; enddo + ! enddo + endif ! To set the length scale based on the deformation radius, use wave_speed to ! calculate the first-mode gravity wave speed and then blend the equatorial @@ -864,49 +900,50 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop do j=js-1,je+1 ; do I=is-1,ie E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) ! Mask slopes where interface intersects topography - if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. + if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. enddo ; enddo do J=js-1,je ; do i=is-1,ie+1 E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) ! Mask slopes where interface intersects topography - if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. + if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. enddo ; enddo else ! This branch is not used. do j=js-1,je+1 ; do I=is-1,ie E_x(I,j) = CS%slope_x(I,j,k) - if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. + if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. enddo ; enddo - do j=js-1,je ; do I=is-1,ie+1 + do J=js-1,je ; do i=is-1,ie+1 E_y(i,J) = CS%slope_y(i,J,k) - if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. + if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. enddo ; enddo endif ! Calculate N*S*h from this layer and add to the sum do j=js,je ; do I=is-1,ie S2 = ( E_x(I,j)**2 + 0.25*( & - (E_y(I,j)**2+E_y(I+1,j-1)**2) + (E_y(I+1,j)**2+E_y(I,j-1)**2) ) ) + (E_y(i,J)**2+E_y(i+1,J-1)**2) + (E_y(i+1,J)**2+E_y(i,J-1)**2) ) ) + if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) S2 = 0.0 + Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i+1,j,k)*h(i+1,j,k-1) / (h(i+1,j,k) + h(i+1,j,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) - if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) & - S2 = 0.0 - S2N2_u_local(I,j,k) = (H_geom * GV%H_to_Z) * S2 * N2 + ! N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + S2N2_u_local(I,j,k) = (H_geom * S2) * (GV%g_prime(k) / max(Hdn, Hup, CS%h_min_N2) ) enddo ; enddo do J=js-1,je ; do i=is,ie S2 = ( E_y(i,J)**2 + 0.25*( & - (E_x(i,J)**2+E_x(i-1,J+1)**2) + (E_x(i,J+1)**2+E_x(i-1,J)**2) ) ) + (E_x(I,j)**2+E_x(I-1,j+1)**2) + (E_x(I,j+1)**2+E_x(I-1,j)**2) ) ) + if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) S2 = 0.0 + Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i,j+1,k)*h(i,j+1,k-1) / (h(i,j+1,k) + h(i,j+1,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) - if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) & - S2 = 0.0 - S2N2_v_local(i,J,k) = (H_geom * GV%H_to_Z) * S2 * N2 + ! N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + S2N2_v_local(i,J,k) = (H_geom * S2) * (GV%g_prime(k) / (max(Hdn, Hup, CS%h_min_N2))) enddo ; enddo enddo ! k + !$OMP parallel do default(shared) do j=js,je do I=is-1,ie ; CS%SN_u(I,j) = 0.0 ; enddo @@ -914,17 +951,22 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop CS%SN_u(I,j) = CS%SN_u(I,j) + S2N2_u_local(I,j,k) enddo ; enddo ! SN above contains S^2*N^2*H, convert to vertical average of S*N - do I=is-1,ie - !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). - !SN_u(I,j) = sqrt( SN_u(I,j) / ( max(G%bathyT(i,j), G%bathyT(i+1,j)) + (G%Z_ref + GV%Angstrom_Z) ) ) - !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then + + if (use_dztot) then + do I=is-1,ie CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / & - (max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref) ) - else - CS%SN_u(I,j) = 0.0 - endif - enddo + max(dz_tot(i,j), dz_tot(i+1,j), GV%dz_subroundoff) ) + enddo + else + do I=is-1,ie + if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > dZ_cutoff ) then + CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / & + (max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref) ) + else + CS%SN_u(I,j) = 0.0 + endif + enddo + endif enddo !$OMP parallel do default(shared) do J=js-1,je @@ -932,17 +974,24 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop do k=nz,CS%VarMix_Ktop,-1 ; do i=is,ie CS%SN_v(i,J) = CS%SN_v(i,J) + S2N2_v_local(i,J,k) enddo ; enddo - do i=is,ie - !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). - !SN_v(i,J) = sqrt( SN_v(i,J) / ( max(G%bathyT(i,J), G%bathyT(i,J+1)) + (G%Z_ref + GV%Angstrom_Z) ) ) - !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then + if (use_dztot) then + do i=is,ie CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / & - (max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref) ) - else - CS%SN_v(i,J) = 0.0 - endif - enddo + max(dz_tot(i,j), dz_tot(i,j+1), GV%dz_subroundoff) ) + enddo + else + do i=is,ie + ! There is a primordial horizontal indexing bug on the following line from the previous + ! versions of the code. This comment should be deleted by the end of 2024. + ! if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > dZ_cutoff ) then + if ( min(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref > dZ_cutoff ) then + CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / & + (max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref) ) + else + CS%SN_v(i,J) = 0.0 + endif + enddo + endif enddo end subroutine calc_slope_functions_using_just_e @@ -982,7 +1031,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo real :: Ih ! The inverse of a combination of thicknesses [H-1 ~> m-1 or m2 kg-1] real :: f ! A copy of the Coriolis parameter [T-1 ~> s-1] real :: inv_PI3 ! The inverse of pi cubed [nondim] - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq,nz + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -1002,8 +1051,8 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_slope_below = 2. * ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) * h(i+1,j,k+1) ) / & ( ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) + h(i+1,j,k+1) ) & + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff**2 ) - Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) - dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * Ih + Ih = 1. / ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) + dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * (GV%Z_to_H * Ih) h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo @@ -1016,8 +1065,8 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_slope_below = 2. * ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) * h(i,j+1,k+1) ) / & ( ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) + h(i,j+1,k+1) ) & + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff**2 ) - Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) - dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * Ih + Ih = 1. / ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) + dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * (GV%Z_to_H * Ih) h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo @@ -1143,7 +1192,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_cg1 = .false. CS%calculate_Rd_dx = .false. CS%calculate_res_fns = .false. - CS%use_simpler_Eady_growth_rate = .false. + CS%use_simpler_Eady_growth_rate = .false. + CS%full_depth_Eady_growth_rate = .false. CS%calculate_depth_fns = .false. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1298,6 +1348,14 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "The minimum vertical distance to use in the denominator of the "//& "bouyancy frequency used in the slope calculation.", & units="m", default=1.0, scale=GV%m_to_H, do_not_log=CS%use_stored_slopes) + + call get_param(param_file, mdl, "FULL_DEPTH_EADY_GROWTH_RATE", CS%full_depth_Eady_growth_rate, & + "If true, calculate the Eady growth rate based on average slope times "//& + "stratification that includes contributions from sea-level changes "//& + "in its denominator, rather than just the nominal depth of the bathymetry. "//& + "This only applies when using the model interface heights as a proxy for "//& + "isopycnal slopes.", default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq), & + do_not_log=CS%use_stored_slopes) endif endif From a41d0a068117a92a2b430d84a443e4313312d603 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 3 Oct 2023 11:54:47 -0400 Subject: [PATCH 101/146] .testing: Codecov upload uses Github Actions token Anonymous uploads to Codecov are throttled (though it is not clear if this is happening on the Codecov or the GitHub Actions side). Regardless, the advice to get around this throttling seems to be to use the Codecov token associated with the project. The .testing Makefile was modified to use this token if provided, and the GitHub Actions environment now attempts to fetch this from the secrets of the repository. Hopefully individual groups can set this for their own projects, and it will fall back to anonymous upload if unset, but I guess we'll have to see how this plays out. --- .github/workflows/coverage.yml | 4 ++++ .testing/Makefile | 10 +++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 9922840420..a54fda32a6 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -42,7 +42,11 @@ jobs: - name: Report coverage to CI (PR) if: github.event_name == 'pull_request' run: make report.cov REQUIRE_COVERAGE_UPLOAD=true + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - name: Report coverage to CI (Push) if: github.event_name != 'pull_request' run: make report.cov + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} diff --git a/.testing/Makefile b/.testing/Makefile index d6b06893fe..c2ab27741a 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -571,13 +571,21 @@ endef # Upload coverage reports CODECOV_UPLOADER_URL ?= https://uploader.codecov.io/latest/linux/codecov +CODECOV_TOKEN ?= + +ifdef CODECOV_TOKEN + CODECOV_TOKEN_ARG = -t $(CODECOV_TOKEN) +else + CODECOV_TOKEN_ARG = +endif + codecov: curl -s $(CODECOV_UPLOADER_URL) -o $@ chmod +x codecov .PHONY: report.cov report.cov: run.cov codecov - ./codecov -R build/cov -Z -f "*.gcov" \ + ./codecov $(CODECOV_TOKEN_ARG) -R build/cov -Z -f "*.gcov" \ > build/cov/codecov.out \ 2> build/cov/codecov.err \ && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ From 7cef1e450e9813af9a0ae3d86ae3b3fa58b39a32 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 27 Jul 2023 07:39:56 -0400 Subject: [PATCH 102/146] +Rename OBC sea surface height variables Renamed OBC related variables to emphasize that they are sea surface heights, and not sea surface heights or total column mass depending on the Boussinesq approximation. Also changed the units of these renamed variables to [Z ~> m] instead of [H ~> m or kg m-2]. The renamed element of the OBC_segment_type is eta (which is now SSH). The renamed and rescaled elements of the BT_OBC_type are H_[uv] (which are now dZ_[uv]) and eta_outer_[uv] (which are now SSH_outer_[uv]). The internal variables H_[uv] and h_in in apply_velocity_OBCs are now dZ_[uv] and ssh_in. Tidal_elev in update_OBC_segment_data and cff_eta in tidal_bay_set_OBC_data were rescaled but not renamed. There is also a new vertical grid type argument to apply_velocity_OBCs for use in changing the scaling of the SSH variables. A total of 11 GV%Z_to_H or GV%H_to_Z rescaling factors were cancelled out as a result of these changes, while 16 new ones were added, but most of these will in turn be dealt with in a follow-on commit that enables the use of OBCs in non-Boussinesq mode. Because any cases that use Flather open boundary conditions with the non-Boussinesq mode issue a fatal error, all answers are bitwise identical, but there are changes to the names and units of elements in a transparent type. --- src/core/MOM_barotropic.F90 | 93 ++++++++++++++------------- src/core/MOM_open_boundary.F90 | 22 ++++--- src/user/Kelvin_initialization.F90 | 8 +-- src/user/tidal_bay_initialization.F90 | 6 +- 4 files changed, 66 insertions(+), 63 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 4c600d37d2..af2ccaa487 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -71,8 +71,8 @@ module MOM_barotropic type, private :: BT_OBC_type real, allocatable :: Cg_u(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1]. real, allocatable :: Cg_v(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1]. - real, allocatable :: H_u(:,:) !< The total thickness at the u-points [H ~> m or kg m-2]. - real, allocatable :: H_v(:,:) !< The total thickness at the v-points [H ~> m or kg m-2]. + real, allocatable :: dZ_u(:,:) !< The total vertical column extent at the u-points [Z ~> m]. + real, allocatable :: dZ_v(:,:) !< The total vertical column extent at the v-points [Z ~> m]. real, allocatable :: uhbt(:,:) !< The zonal barotropic thickness fluxes specified !! for open boundary conditions (if any) [H L2 T-1 ~> m3 s-1 or kg s-1]. real, allocatable :: vhbt(:,:) !< The meridional barotropic thickness fluxes specified @@ -81,10 +81,10 @@ module MOM_barotropic !! as set by the open boundary conditions [L T-1 ~> m s-1]. real, allocatable :: vbt_outer(:,:) !< The meridional velocities just outside the domain, !! as set by the open boundary conditions [L T-1 ~> m s-1]. - real, allocatable :: eta_outer_u(:,:) !< The surface height outside of the domain - !! at a u-point with an open boundary condition [H ~> m or kg m-2]. - real, allocatable :: eta_outer_v(:,:) !< The surface height outside of the domain - !! at a v-point with an open boundary condition [H ~> m or kg m-2]. + real, allocatable :: SSH_outer_u(:,:) !< The surface height outside of the domain + !! at a u-point with an open boundary condition [Z ~> m]. + real, allocatable :: SSH_outer_v(:,:) !< The surface height outside of the domain + !! at a v-point with an open boundary condition [Z ~> m]. logical :: apply_u_OBCs !< True if this PE has an open boundary at a u-point. logical :: apply_v_OBCs !< True if this PE has an open boundary at a v-point. !>@{ Index ranges for the open boundary conditions @@ -2338,7 +2338,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP single 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, integral_BT_cont, & + G, MS, GV, 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) !$OMP end single @@ -2908,11 +2908,11 @@ end subroutine set_dtbt !! 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, & + ubt_old, vbt_old, BT_OBC, G, MS, GV, 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(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. 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(inout) :: ubt !< the zonal barotropic velocity [L T-1 ~> m s-1]. @@ -2935,6 +2935,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, type(BT_OBC_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays !! related to the open boundary conditions, !! set by set_up_BT_OBC. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: halo !< The extra halo size to use here. real, intent(in) :: dtbt !< The time step [T ~> s]. @@ -2978,14 +2979,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. real :: vel_trans ! The combination of the previous and current velocity ! that does the mass transport [L T-1 ~> m s-1]. - real :: H_u ! The total thickness at the u-point [H ~> m or kg m-2]. - real :: H_v ! The total thickness at the v-point [H ~> m or kg m-2]. + real :: dZ_u ! The total vertical column extent at a u-point [Z ~> m] + real :: dZ_v ! The total vertical column extent at a v-point [Z ~> m] 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 :: 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 thickness [H ~> m or kg m-2]. + real :: ssh_in ! The inflow sea surface height [Z ~> m] real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -3004,11 +3005,11 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal - H_u = BT_OBC%H_u(I,j) + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j))) ! internal + dZ_u = BT_OBC%dZ_u(I,j) vel_prev = ubt(I,j) ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/H_u) * (h_in-BT_OBC%eta_outer_u(I,j))) + (BT_OBC%Cg_u(I,j)/dZ_u) * (ssh_in-BT_OBC%SSH_outer_u(I,j))) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then ubt(I,j) = ubt(I-1,j) @@ -3018,12 +3019,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! external + ssh_in = GV%H_to_Z*(eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j))) ! internal - H_u = BT_OBC%H_u(I,j) + dZ_u = BT_OBC%dZ_u(I,j) vel_prev = ubt(I,j) ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/H_u) * (BT_OBC%eta_outer_u(I,j)-h_in)) + (BT_OBC%Cg_u(I,j)/dZ_u) * (BT_OBC%SSH_outer_u(I,j)-ssh_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then @@ -3058,12 +3059,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then 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 + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1))) ! internal - H_v = BT_OBC%H_v(i,J) + dZ_v = BT_OBC%dZ_v(i,J) vel_prev = vbt(i,J) vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/H_v) * (h_in-BT_OBC%eta_outer_v(i,J))) + (BT_OBC%Cg_v(i,J)/dZ_v) * (ssh_in-BT_OBC%SSH_outer_v(i,J))) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then @@ -3074,12 +3075,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then 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 + ssh_in = GV%H_to_Z*(eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2))) ! internal - H_v = BT_OBC%H_v(i,J) + dZ_v = BT_OBC%dZ_v(i,J) vel_prev = vbt(i,J) vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/H_v) * (BT_OBC%eta_outer_v(i,J)-h_in)) + (BT_OBC%Cg_v(i,J)/dZ_v) * (BT_OBC%SSH_outer_v(i,J)-ssh_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then @@ -3167,21 +3168,21 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B if (.not. BT_OBC%is_alloced) then allocate(BT_OBC%Cg_u(isdw-1:iedw,jsdw:jedw), source=0.0) - allocate(BT_OBC%H_u(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%dZ_u(isdw-1:iedw,jsdw:jedw), source=0.0) allocate(BT_OBC%uhbt(isdw-1:iedw,jsdw:jedw), source=0.0) allocate(BT_OBC%ubt_outer(isdw-1:iedw,jsdw:jedw), source=0.0) - allocate(BT_OBC%eta_outer_u(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%SSH_outer_u(isdw-1:iedw,jsdw:jedw), source=0.0) allocate(BT_OBC%Cg_v(isdw:iedw,jsdw-1:jedw), source=0.0) - allocate(BT_OBC%H_v(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%dZ_v(isdw:iedw,jsdw-1:jedw), source=0.0) allocate(BT_OBC%vhbt(isdw:iedw,jsdw-1:jedw), source=0.0) allocate(BT_OBC%vbt_outer(isdw:iedw,jsdw-1:jedw), source=0.0) - allocate(BT_OBC%eta_outer_v(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%SSH_outer_v(isdw:iedw,jsdw-1:jedw), source=0.0) BT_OBC%is_alloced = .true. call create_group_pass(BT_OBC%pass_uv, BT_OBC%ubt_outer, BT_OBC%vbt_outer, BT_Domain) call create_group_pass(BT_OBC%pass_uhvh, BT_OBC%uhbt, BT_OBC%vhbt, BT_Domain) - call create_group_pass(BT_OBC%pass_eta_outer, BT_OBC%eta_outer_u, BT_OBC%eta_outer_v, BT_Domain,To_All+Scalar_Pair) - call create_group_pass(BT_OBC%pass_h, BT_OBC%H_u, BT_OBC%H_v, BT_Domain,To_All+Scalar_Pair) + call create_group_pass(BT_OBC%pass_eta_outer, BT_OBC%SSH_outer_u, BT_OBC%SSH_outer_v, BT_Domain,To_All+Scalar_Pair) + call create_group_pass(BT_OBC%pass_h, BT_OBC%dZ_u, BT_OBC%dZ_v, BT_Domain,To_All+Scalar_Pair) call create_group_pass(BT_OBC%pass_cg, BT_OBC%Cg_u, BT_OBC%Cg_v, BT_Domain,To_All+Scalar_Pair) endif @@ -3212,18 +3213,18 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%H_u(I,j) = G%bathyT(i,j)*GV%Z_to_H + eta(i,j) + BT_OBC%dZ_u(I,j) = G%bathyT(i,j) + GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%H_u(I,j) = G%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) + BT_OBC%dZ_u(I,j) = G%bathyT(i+1,j) + GV%H_to_Z*eta(i+1,j) endif else if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%H_u(I,j) = eta(i,j) + BT_OBC%dZ_u(I,j) = GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%H_u(I,j) = eta(i+1,j) + BT_OBC%dZ_u(I,j) = GV%H_to_Z*eta(i+1,j) endif endif - BT_OBC%Cg_u(I,j) = SQRT(dgeo_de_in * GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_u(i,j)) + BT_OBC%Cg_u(I,j) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_u(i,j)) endif endif ; enddo ; enddo if (OBC%Flather_u_BCs_exist_globally) then @@ -3232,7 +3233,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B if (segment%is_E_or_W .and. segment%Flather) then do j=segment%HI%jsd,segment%HI%jed ; do I=segment%HI%IsdB,segment%HI%IedB BT_OBC%ubt_outer(I,j) = segment%normal_vel_bt(I,j) - BT_OBC%eta_outer_u(I,j) = segment%eta(I,j) + G%Z_ref*GV%Z_to_H + BT_OBC%SSH_outer_u(I,j) = segment%SSH(I,j) + G%Z_ref enddo ; enddo endif enddo @@ -3266,18 +3267,18 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%H_v(i,J) = G%bathyT(i,j)*GV%Z_to_H + eta(i,j) + BT_OBC%dZ_v(i,J) = G%bathyT(i,j) + GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%H_v(i,J) = G%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) + BT_OBC%dZ_v(i,J) = G%bathyT(i,j+1) + GV%H_to_Z*eta(i,j+1) endif else if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%H_v(i,J) = eta(i,j) + BT_OBC%dZ_v(i,J) = GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%H_v(i,J) = eta(i,j+1) + BT_OBC%dZ_v(i,J) = GV%H_to_Z*eta(i,j+1) endif endif - BT_OBC%Cg_v(i,J) = SQRT(dgeo_de_in * GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_v(i,J)) + BT_OBC%Cg_v(i,J) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_v(i,J)) endif endif ; enddo ; enddo if (OBC%Flather_v_BCs_exist_globally) then @@ -3286,7 +3287,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B if (segment%is_N_or_S .and. segment%Flather) then do J=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied BT_OBC%vbt_outer(i,J) = segment%normal_vel_bt(i,J) - BT_OBC%eta_outer_v(i,J) = segment%eta(i,J) + G%Z_ref*GV%Z_to_H + BT_OBC%SSH_outer_v(i,J) = segment%SSH(i,J) + G%Z_ref enddo ; enddo endif enddo @@ -3309,16 +3310,16 @@ subroutine destroy_BT_OBC(BT_OBC) if (BT_OBC%is_alloced) then deallocate(BT_OBC%Cg_u) - deallocate(BT_OBC%H_u) + deallocate(BT_OBC%dZ_u) deallocate(BT_OBC%uhbt) deallocate(BT_OBC%ubt_outer) - deallocate(BT_OBC%eta_outer_u) + deallocate(BT_OBC%SSH_outer_u) deallocate(BT_OBC%Cg_v) - deallocate(BT_OBC%H_v) + deallocate(BT_OBC%dZ_v) deallocate(BT_OBC%vhbt) deallocate(BT_OBC%vbt_outer) - deallocate(BT_OBC%eta_outer_v) + deallocate(BT_OBC%SSH_outer_v) BT_OBC%is_alloced = .false. endif end subroutine destroy_BT_OBC diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 36a71e3d52..7fb50bc72f 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -200,8 +200,8 @@ module MOM_open_boundary !! segment [H L2 T-1 ~> m3 s-1]. real, allocatable :: normal_vel_bt(:,:) !< The barotropic velocity normal to !! the OB segment [L T-1 ~> m s-1]. - real, allocatable :: eta(:,:) !< The sea-surface elevation along the - !! segment [H ~> m or kg m-2]. + real, allocatable :: SSH(:,:) !< The sea-surface elevation along the + !! segment [Z ~> m]. real, allocatable :: grad_normal(:,:,:) !< The gradient of the normal flow along the !! segment times the grid spacing [L T-1 ~> m s-1], !! with the first index being the corner-point index @@ -3581,7 +3581,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%Cg(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%Htot(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) - allocate(segment%eta(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%SSH(IsdB:IedB,jsd:jed), source=0.0) if (segment%radiation) & allocate(segment%rx_norm_rad(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) allocate(segment%normal_vel(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) @@ -3616,7 +3616,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%Cg(isd:ied,JsdB:JedB), source=0.0) allocate(segment%Htot(isd:ied,JsdB:JedB), source=0.0) allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke), source=0.0) - allocate(segment%eta(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%SSH(isd:ied,JsdB:JedB), source=0.0) if (segment%radiation) & allocate(segment%ry_norm_rad(isd:ied,JsdB:JedB,OBC%ke), source=0.0) allocate(segment%normal_vel(isd:ied,JsdB:JedB,OBC%ke), source=0.0) @@ -3657,7 +3657,7 @@ subroutine deallocate_OBC_segment_data(segment) if (allocated(segment%Cg)) deallocate(segment%Cg) if (allocated(segment%Htot)) deallocate(segment%Htot) if (allocated(segment%h)) deallocate(segment%h) - if (allocated(segment%eta)) deallocate(segment%eta) + if (allocated(segment%SSH)) deallocate(segment%SSH) if (allocated(segment%rx_norm_rad)) deallocate(segment%rx_norm_rad) if (allocated(segment%ry_norm_rad)) deallocate(segment%ry_norm_rad) if (allocated(segment%rx_norm_obl)) deallocate(segment%rx_norm_obl) @@ -3797,7 +3797,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) real :: net_H_int ! Total thickness of the incoming flow in the model [H ~> m or kg m-2] real :: scl_fac ! A scaling factor to compensate for differences in total thicknesses [nondim] real :: tidal_vel ! Interpolated tidal velocity at the OBC points [L T-1 ~> m s-1] - real :: tidal_elev ! Interpolated tidal elevation at the OBC points [H ~> m or kg m-2] + real :: tidal_elev ! Interpolated tidal elevation at the OBC points [Z ~> m] real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1] integer :: turns ! Number of index quarter turns real :: time_delta ! Time since tidal reference date [T ~> s] @@ -4376,12 +4376,13 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if (OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + tidal_elev = tidal_elev + (OBC%tide_fn(c) * & + GV%H_to_Z*segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - segment%eta(i,j) = OBC%ramp_value * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + segment%SSH(i,j) = OBC%ramp_value * (GV%H_to_Z*segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo else @@ -4390,12 +4391,13 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if (OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + tidal_elev = tidal_elev + (OBC%tide_fn(c) * & + GV%H_to_Z*segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - segment%eta(i,j) = (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + segment%SSH(i,j) = (GV%H_to_Z*segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo endif diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 88d0cbb482..1fc8a2f564 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -265,7 +265,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) ! Use inside bathymetry cff = sqrt(GV%g_Earth * depth_tot(i+1,j) ) val2 = mag_SSH * exp(- CS%F_0 * y / cff) - segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) + segment%SSH(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) if (segment%nudged) then do k=1,nz @@ -279,7 +279,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) endif else ! Baroclinic, not rotated yet - segment%eta(I,j) = 0.0 + segment%SSH(I,j) = 0.0 segment%normal_vel_bt(I,j) = 0.0 if (segment%nudged) then do k=1,nz @@ -323,7 +323,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (CS%mode == 0) then cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) - segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) + segment%SSH(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = (val1 * cff * sina / depth_tot(i,j+1) ) * val2 if (segment%nudged) then do k=1,nz @@ -337,7 +337,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) endif else ! Not rotated yet - segment%eta(i,J) = 0.0 + segment%SSH(i,J) = 0.0 segment%normal_vel_bt(i,J) = 0.0 if (segment%nudged) then do k=1,nz diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 4a20f0e9b3..37a908d3a8 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -74,7 +74,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) ! The following variables are used to set up the transport in the tidal_bay example. real :: time_sec ! Elapsed model time [T ~> s] - real :: cff_eta ! The total column thickness anomalies associated with the inflow [H ~> m or kg m-2] + real :: cff_eta ! The sea surface height anomalies associated with the inflow [Z ~> m] real :: my_flux ! The vlume flux through the face [L2 Z T-1 ~> m3 s-1] real :: total_area ! The total face area of the OBCs [L Z ~> m2] real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] @@ -97,7 +97,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) flux_scale = GV%H_to_m*US%L_to_m time_sec = US%s_to_T*time_type_to_real(Time) - cff_eta = CS%tide_ssh_amp*GV%Z_to_H * sin(2.0*PI*time_sec / CS%tide_period) + cff_eta = CS%tide_ssh_amp * sin(2.0*PI*time_sec / CS%tide_period) my_area = 0.0 my_flux = 0.0 segment => OBC%segment(1) @@ -119,7 +119,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (.not. segment%on_pe) cycle segment%normal_vel_bt(:,:) = my_flux / (US%m_to_Z*US%m_to_L*total_area) - segment%eta(:,:) = cff_eta + segment%SSH(:,:) = cff_eta enddo ! end segment loop From de385624ba4e8567685d09e9c8cd8142eb93612b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 Jul 2023 16:50:17 -0400 Subject: [PATCH 103/146] Read OBC SSH data in Z units Read in open boundary condition SSH and SSHamp segment data directly in rescaled units of [Z ~> m] instead of [H ~> m or kg m-2], which then has to undergo a subsequent conversion. All answers in Boussinesq mode are bitwise identical and non-Boussinesq mode does not work with OBCs yet. --- src/core/MOM_open_boundary.F90 | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 7fb50bc72f..86bec85b68 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1064,8 +1064,8 @@ real function scale_factor_from_name(name, GV, US, Tr_Reg) case ('Vamp') ; scale_factor_from_name = US%m_s_to_L_T case ('DVDX') ; scale_factor_from_name = US%T_to_s case ('DUDY') ; scale_factor_from_name = US%T_to_s - case ('SSH') ; scale_factor_from_name = GV%m_to_H - case ('SSHamp') ; scale_factor_from_name = GV%m_to_H + case ('SSH') ; scale_factor_from_name = US%m_to_Z + case ('SSHamp') ; scale_factor_from_name = US%m_to_Z case default ; scale_factor_from_name = 1.0 end select @@ -4376,13 +4376,12 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if (OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * & - GV%H_to_Z*segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - segment%SSH(i,j) = OBC%ramp_value * (GV%H_to_Z*segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + segment%SSH(i,j) = OBC%ramp_value * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo else @@ -4391,13 +4390,12 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if (OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * & - GV%H_to_Z*segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - segment%SSH(i,j) = (GV%H_to_Z*segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + segment%SSH(i,j) = (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo endif From 55c948ad7e9dd3b3c65a79856eee00ae79fe607d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 Jul 2023 16:50:44 -0400 Subject: [PATCH 104/146] +Add find_col_avg_SpV Added the new subroutine find_col_avg_SpV to return the column-averaged specific volume based on the coordinate mode and the layer averaged specific volumes that are in tv%SpV_avg. All answers are bitwise identical, but there is a new publicly visible routine. --- src/core/MOM_interface_heights.F90 | 70 +++++++++++++++++++++++++++++- 1 file changed, 69 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 194c39c76d..3dfbc89a03 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -19,7 +19,7 @@ module MOM_interface_heights public find_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple public calc_derived_thermo -public find_rho_bottom +public find_rho_bottom, find_col_avg_SpV !> Calculates the heights of the free surface or all interfaces from layer thicknesses. interface find_eta @@ -323,6 +323,74 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) end subroutine calc_derived_thermo +!> Determine the column average specific volumes. +subroutine find_col_avg_SpV(h, SpV_avg, tv, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: SpV_avg !< Column average specific volume [R-1 ~> m3 kg-1] + ! SpV_avg is intent inout to retain excess halo values. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, optional, intent(in) :: halo_size !< width of halo points on which to work + + ! Local variables + real :: h_tot(SZI_(G)) ! Sum of the layer thicknesses [H ~> m or kg m-3] + real :: SpV_x_h_tot(SZI_(G)) ! Vertical sum of the layer average specific volume times + ! the layer thicknesses [H R-1 ~> m4 kg-1 or m] + real :: I_rho ! The inverse of the Boussiensq reference density [R-1 ~> m3 kg-1] + real :: SpV_lay(SZK_(GV)) ! The inverse of the layer target potential densities [R-1 ~> m3 kg-1] + character(len=128) :: mesg ! A string for error messages + integer i, j, k, is, ie, js, je, nz, halo + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + nz = GV%ke + + if (GV%Boussinesq) then + I_rho = 1.0 / GV%Rho0 + do j=js,je ; do i=is,ie + SpV_avg(i,j) = I_rho + enddo ; enddo + elseif (.not.allocated(tv%SpV_avg)) then + do k=1,nz ; Spv_lay(k) = 1.0 / GV%Rlay(k) ; enddo + do j=js,je + do i=is,ie ; SpV_x_h_tot(i) = 0.0 ; h_tot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + h_tot(i) = h_tot(i) + max(h(i,j,k), GV%H_subroundoff) + SpV_x_h_tot(i) = SpV_x_h_tot(i) + Spv_lay(k)*max(h(i,j,k), GV%H_subroundoff) + enddo ; enddo + do i=is,ie ; SpV_avg(i,j) = SpV_x_h_tot(i) / h_tot(i) ; enddo + enddo + else + ! Check that SpV_avg has been set. + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "find_col_avg_SpV called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do j=js,je + do i=is,ie ; SpV_x_h_tot(i) = 0.0 ; h_tot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + h_tot(i) = h_tot(i) + max(h(i,j,k), GV%H_subroundoff) + SpV_x_h_tot(i) = SpV_x_h_tot(i) + tv%SpV_avg(i,j,k)*max(h(i,j,k), GV%H_subroundoff) + enddo ; enddo + do i=is,ie ; SpV_avg(i,j) = SpV_x_h_tot(i) / h_tot(i) ; enddo + enddo + endif + +end subroutine find_col_avg_SpV + + !> Determine the in situ density averaged over a specified distance from the bottom, !! calculating it as the inverse of the mass-weighted average specific volume. subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) From 54b46f6215a4a81c0e212885d15a4ec51f868c1c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 Jul 2023 16:59:21 -0400 Subject: [PATCH 105/146] +Non-Boussinesq Flather open boundary conditions Get Flather open boundary conditions working properly in non-Boussinesq mode. This includes calculating the column-average specific volume in step_MOM_dyn_split_RK2 and passing it as a new argument to btstep. Inside of btstep, this is copied over into a wide halo array and then passed on to set_up_BT_OBC and apply_velocity_OBCs, where it is used to determine the free surface height or the vertical column extent (in [Z ~> m]) from eta for use in the Flather radiation open boundary conditions. In addition, there are several places in MOM_barotropic related to the open boundary conditions where the usual G%bathyT needed to be replaced with its wide-halo counterpart, CS%bathyT. Also, a test was added for massless OBC columns in apply_velocity_OBCs, which are then assumed to be dry rather than dividing by zero. A fatal error message that is triggered in the case of Flather open boundary conditions in non-Boussiesq mode was removed. With this change, all Boussinesq answers are bitwise identical, but non-Boussinesq cases with Flather open boundary conditions are now working and giving answers that are qualitatively similar to the Boussinesq cases. --- src/core/MOM_barotropic.F90 | 162 +++++++++++++++++++--------- src/core/MOM_dynamics_split_RK2.F90 | 17 ++- 2 files changed, 125 insertions(+), 54 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index af2ccaa487..4a5dba294a 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -306,6 +306,7 @@ module MOM_barotropic type(group_pass_type) :: pass_ubt_Cor !< Handle for a group halo pass type(group_pass_type) :: pass_ubta_uhbta !< Handle for a group halo pass type(group_pass_type) :: pass_e_anom !< Handle for a group halo pass + type(group_pass_type) :: pass_SpV_avg !< Handle for a group halo pass !>@{ Diagnostic IDs integer :: id_PFu_bt = -1, id_PFv_bt = -1, id_Coru_bt = -1, id_Corv_bt = -1 @@ -422,7 +423,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, ADp, OBC, BT_cont, eta_PF_start, & + visc_rem_u, visc_rem_v, SpV_avg, ADp, OBC, BT_cont, eta_PF_start, & taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0, etaav) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -472,6 +473,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !! viscosity is applied, in the zonal direction [nondim]. !! Visc_rem_u is between 0 (at the bottom) and 1 (far above). real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SpV_avg !< The column average specific volume, used + !! in non-Boussinesq OBC calculations [R-1 ~> m3 kg-1] type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers type(ocean_OBC_type), pointer :: OBC !< The open boundary condition structure. type(BT_cont_type), pointer :: BT_cont !< A structure with elements that describe @@ -614,6 +617,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! from the thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. ! (See Hallberg, J Comp Phys 1997 for a discussion.) eta_src, & ! The source of eta per barotropic timestep [H ~> m or kg m-2]. + SpV_col_avg, & ! The column average specific volume [R-1 ~> m3 kg-1] dyn_coef_eta, & ! The coefficient relating the changes in eta to the ! dynamic surface pressure under rigid ice ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. @@ -773,10 +777,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, apply_OBC_open = open_boundary_query(OBC, apply_open_OBC=.true.) apply_OBCs = open_boundary_query(OBC, apply_specified_OBC=.true.) .or. & apply_OBC_flather .or. apply_OBC_open - - if (apply_OBC_flather .and. .not.GV%Boussinesq) call MOM_error(FATAL, & - "btstep: Flather open boundary conditions have not yet been "// & - "implemented for a non-Boussinesq model.") endif num_cycles = 1 @@ -866,6 +866,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (apply_OBC_open) & call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) endif + if (apply_OBC_flather .and. .not.GV%Boussinesq) & + call create_group_pass(CS%pass_SpV_avg, SpV_col_avg, CS%BT_domain) 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 @@ -979,6 +981,22 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0 enddo ; enddo + if (apply_OBCs) then + SpV_col_avg(:,:) = 0.0 + if (apply_OBC_flather .and. .not.GV%Boussinesq) then + ! Copy the column average specific volumes into a wide halo array + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + SpV_col_avg(i,j) = Spv_avg(i,j) + enddo ; enddo + if (nonblock_setup) then + call start_group_pass(CS%pass_SpV_avg, CS%BT_domain) + else + call do_group_pass(CS%pass_SpV_avg, CS%BT_domain) + endif + endif + endif + if (CS%linear_wave_drag) then !$OMP parallel do default(shared) do j=CS%jsdw,CS%jedw ; do I=CS%isdw-1,CS%iedw @@ -1125,12 +1143,15 @@ 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 + if (nonblock_setup .and. apply_OBC_flather .and. .not.GV%Boussinesq) & + call complete_group_pass(CS%pass_SpV_avg, CS%BT_domain) + if (CS%TIDAL_SAL_FLATHER) then - call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) + call set_up_BT_OBC(OBC, eta, SpV_col_avg, CS%BT_OBC, CS%BT_Domain, G, GV, US, CS, MS, ievf-ie, & + use_BT_cont, integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) else - call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) + call set_up_BT_OBC(OBC, eta, SpV_col_avg, CS%BT_OBC, CS%BT_Domain, G, GV, US, CS, MS, ievf-ie, & + use_BT_cont, integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) endif endif @@ -2337,8 +2358,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP single call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & - ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, GV, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + ubt_trans, vbt_trans, eta, SpV_col_avg, ubt_old, vbt_old, CS%BT_OBC, & + G, MS, GV, US, CS, 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) !$OMP end single @@ -2907,8 +2928,8 @@ 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, GV, US, halo, dtbt, bebt, & +subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, SpV_avg, & + ubt_old, vbt_old, BT_OBC, G, MS, GV, US, CS, 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. @@ -2928,6 +2949,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! transports [L T-1 ~> m s-1]. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or !! column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic !! step [L T-1 ~> m s-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of vbt in a barotropic @@ -2937,6 +2959,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! set by set_up_BT_OBC. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure integer, intent(in) :: halo !< The extra halo size to use here. real, intent(in) :: dtbt !< The time step [T ~> s]. real, intent(in) :: bebt !< The fractional weighting of the future velocity @@ -2979,14 +3002,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. real :: vel_trans ! The combination of the previous and current velocity ! that does the mass transport [L T-1 ~> m s-1]. - real :: dZ_u ! The total vertical column extent at a u-point [Z ~> m] - real :: dZ_v ! The total vertical column extent at a v-point [Z ~> m] 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 :: 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 :: ssh_in ! The inflow sea surface height [Z ~> m] + real :: ssh_1 ! The sea surface height in the interior cell adjacent to the an OBC face [Z ~> m] + real :: ssh_2 ! The sea surface height in the next cell inward from the OBC face [Z ~> m] real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -3005,12 +3028,22 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j))) ! internal - dZ_u = BT_OBC%dZ_u(I,j) - vel_prev = ubt(I,j) - ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/dZ_u) * (ssh_in-BT_OBC%SSH_outer_u(I,j))) - vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - (CS%bathyT(i,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i-1,j) * SpV_avg(i-1,j) - (CS%bathyT(i-1,j) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + if (BT_OBC%dZ_u(I,j) > 0.0) then + vel_prev = ubt(I,j) + ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & + (BT_OBC%Cg_u(I,j)/BT_OBC%dZ_u(I,j)) * (ssh_in-BT_OBC%SSH_outer_u(I,j))) + vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + else ! This point is now dry. + ubt(I,j) = 0.0 + vel_trans = 0.0 + endif elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then ubt(I,j) = ubt(I-1,j) vel_trans = ubt(I,j) @@ -3019,14 +3052,23 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - ssh_in = GV%H_to_Z*(eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j))) ! internal - - dZ_u = BT_OBC%dZ_u(I,j) - vel_prev = ubt(I,j) - ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/dZ_u) * (BT_OBC%SSH_outer_u(I,j)-ssh_in)) + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i+1,j) * SpV_avg(i+1,j) - (CS%bathyT(i+1,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i+2,j) * SpV_avg(i+2,j) - (CS%bathyT(i+2,j) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif - vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + if (BT_OBC%dZ_u(I,j) > 0.0) then + vel_prev = ubt(I,j) + ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & + (BT_OBC%Cg_u(I,j)/BT_OBC%dZ_u(I,j)) * (BT_OBC%SSH_outer_u(I,j)-ssh_in)) + vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + else ! This point is now dry. + ubt(I,j) = 0.0 + vel_trans = 0.0 + endif elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then ubt(I,j) = ubt(I+1,j) vel_trans = ubt(I,j) @@ -3059,14 +3101,23 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then 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 - ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1))) ! internal - - dZ_v = BT_OBC%dZ_v(i,J) - vel_prev = vbt(i,J) - vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/dZ_v) * (ssh_in-BT_OBC%SSH_outer_v(i,J))) + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - (CS%bathyT(i,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i,j-1) * SpV_avg(i,j-1) - (CS%bathyT(i,j-1) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif - vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + if (BT_OBC%dZ_v(i,J) > 0.0) then + vel_prev = vbt(i,J) + vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & + (BT_OBC%Cg_v(i,J)/BT_OBC%dZ_v(i,J)) * (ssh_in-BT_OBC%SSH_outer_v(i,J))) + vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + else ! This point is now dry + vbt(i,J) = 0.0 + vel_trans = 0.0 + endif elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then vbt(i,J) = vbt(i,J-1) vel_trans = vbt(i,J) @@ -3075,14 +3126,23 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then 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 - ssh_in = GV%H_to_Z*(eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2))) ! internal - - dZ_v = BT_OBC%dZ_v(i,J) - vel_prev = vbt(i,J) - vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/dZ_v) * (BT_OBC%SSH_outer_v(i,J)-ssh_in)) + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j+1) * SpV_avg(i,j+1) - (CS%bathyT(i,j+1) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i,j+2) * SpV_avg(i,j+2) - (CS%bathyT(i,j+2) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif - vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + if (BT_OBC%dZ_v(i,J) > 0.0) then + vel_prev = vbt(i,J) + vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & + (BT_OBC%Cg_v(i,J)/BT_OBC%dZ_v(i,J)) * (BT_OBC%SSH_outer_v(i,J)-ssh_in)) + vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + else ! This point is now dry + vbt(i,J) = 0.0 + vel_trans = 0.0 + endif elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then vbt(i,J) = vbt(i,J+1) vel_trans = vbt(i,J) @@ -3109,13 +3169,14 @@ 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, & +subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS, halo, use_BT_cont, & integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) type(ocean_OBC_type), target, intent(inout) :: 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. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or !! column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1] type(BT_OBC_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays !! related to the open boundary conditions, !! set by set_up_BT_OBC. @@ -3123,6 +3184,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure 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. @@ -3141,7 +3203,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used !! for a dynamic estimate of the face areas at !! v-points. - real, intent(in), optional :: dgeo_de !< The constant of proportionality between + real, optional, intent(in) :: dgeo_de !< The constant of proportionality between !! geopotential and sea surface height [nondim]. ! Local variables real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. @@ -3213,15 +3275,15 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%dZ_u(I,j) = G%bathyT(i,j) + GV%H_to_Z*eta(i,j) + BT_OBC%dZ_u(I,j) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%dZ_u(I,j) = G%bathyT(i+1,j) + GV%H_to_Z*eta(i+1,j) + BT_OBC%dZ_u(I,j) = CS%bathyT(i+1,j) + GV%H_to_Z*eta(i+1,j) endif else if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%dZ_u(I,j) = GV%H_to_Z*eta(i,j) + BT_OBC%dZ_u(I,j) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%dZ_u(I,j) = GV%H_to_Z*eta(i+1,j) + BT_OBC%dZ_u(I,j) = GV%H_to_RZ * eta(i+1,j) * SpV_avg(i+1,j) endif endif BT_OBC%Cg_u(I,j) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_u(i,j)) @@ -3267,9 +3329,9 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%dZ_v(i,J) = G%bathyT(i,j) + GV%H_to_Z*eta(i,j) + BT_OBC%dZ_v(i,J) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%dZ_v(i,J) = G%bathyT(i,j+1) + GV%H_to_Z*eta(i,j+1) + BT_OBC%dZ_v(i,J) = CS%bathyT(i,j+1) + GV%H_to_Z*eta(i,j+1) endif else if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index ae9e304736..feb0b7e582 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -50,11 +50,11 @@ module MOM_dynamics_split_RK2 use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS use MOM_hor_visc, only : hor_visc_init, hor_visc_end -use MOM_interface_heights, only : find_eta, thickness_to_dz +use MOM_interface_heights, only : thickness_to_dz, find_col_avg_SpV use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds -use MOM_open_boundary, only : open_boundary_zero_normal_flow +use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp use MOM_PressureForce, only : PressureForce, PressureForce_CS use MOM_PressureForce, only : PressureForce_init @@ -344,6 +344,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s real, dimension(SZI_(G),SZJ_(G)) :: eta_pred ! The predictor value of the free surface height ! or column mass [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)) :: SpV_avg ! The column averaged specific volume [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! A diagnostic of the time derivative of the free surface ! height or column mass [H T-1 ~> m s-1 or kg m-2 s-1] @@ -596,6 +597,14 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (.not.BT_cont_BT_thick) & call btcalc(h, G, GV, CS%barotropic_CSp, OBC=CS%OBC) call bt_mass_source(h, eta, .true., G, GV, CS%barotropic_CSp) + + SpV_avg(:,:) = 0.0 + if ((.not.GV%Boussinesq) .and. associated(CS%OBC)) then + ! Determine the column average specific volume if it is needed due to the + ! use of Flather open boundary conditions in non-Boussinesq mode. + if (open_boundary_query(CS%OBC, apply_Flather_OBC=.true.)) & + call find_col_avg_SpV(h, SpV_avg, tv, G, GV, US) + endif call cpu_clock_end(id_clock_btcalc) if (G%nonblocking_updates) & @@ -625,7 +634,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! The CS%ADp argument here stores the weights for certain integrated diagnostics. 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, CS%ADp, CS%OBC, CS%BT_cont, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr) if (showCallTree) call callTree_leave("btstep()") call cpu_clock_end(id_clock_btstep) @@ -847,7 +856,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! This is the corrector 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, CS%ADp, CS%OBC, CS%BT_cont, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) if (CS%id_deta_dt>0) then do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo From 06bc0018c2efca502eaf7e34fa1d2d4564c9c2fd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 29 Jul 2023 05:31:31 -0400 Subject: [PATCH 106/146] +Add segment%dZtot Add the new element dZtot to the OBC_segment_type to hold the total vertical extent of the water column, and use thickness_to_dz in update_OBC_segment_data to convert the layer thicknesses to the vertical layer extents used to set dZtot. This change leads to the cancellation of 6 unit conversion factors. All answers are bitwise identical in Boussinesq mode, but they will change and become less dependent on the Boussinesq reference density in some Boussinesq cases with certain types of open boundary condition. --- src/core/MOM_open_boundary.F90 | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 86bec85b68..d32e947da1 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -14,6 +14,7 @@ module MOM_open_boundary use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_grid, only : ocean_grid_type, hor_index_type use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : slasher, field_size, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc use MOM_restart, only : register_restart_field, register_restart_pair @@ -189,6 +190,7 @@ module MOM_open_boundary real, allocatable :: Cg(:,:) !< The external gravity wave speed [L T-1 ~> m s-1] !! at OBC-points. real, allocatable :: Htot(:,:) !< The total column thickness [H ~> m or kg m-2] at OBC-points. + real, allocatable :: dZtot(:,:) !< The total column vertical extent [Z ~> m] at OBC-points. real, allocatable :: h(:,:,:) !< The cell thickness [H ~> m or kg m-2] at OBC-points. real, allocatable :: normal_vel(:,:,:) !< The layer velocity normal to the OB !! segment [L T-1 ~> m s-1]. @@ -352,7 +354,7 @@ module MOM_open_boundary real, allocatable :: tres_y(:,:,:,:) !< Array storage of tracer reservoirs for restarts, in unscaled units [conc] logical :: debug !< If true, write verbose checksums for debugging purposes. real :: silly_h !< A silly value of thickness outside of the domain that can be used to test - !! the independence of the OBCs to this external data [H ~> m or kg m-2]. + !! the independence of the OBCs to this external data [Z ~> m]. real :: silly_u !< A silly value of velocity outside of the domain that can be used to test !! the independence of the OBCs to this external data [L T-1 ~> m s-1]. logical :: ramp = .false. !< If True, ramp from zero to the external values for SSH. @@ -3580,6 +3582,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) ! If these are just Flather, change update_OBC_segment_data accordingly allocate(segment%Cg(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%Htot(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%dZtot(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) allocate(segment%SSH(IsdB:IedB,jsd:jed), source=0.0) if (segment%radiation) & @@ -3615,6 +3618,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) ! If these are just Flather, change update_OBC_segment_data accordingly allocate(segment%Cg(isd:ied,JsdB:JedB), source=0.0) allocate(segment%Htot(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%dZtot(isd:ied,JsdB:JedB), source=0.0) allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke), source=0.0) allocate(segment%SSH(isd:ied,JsdB:JedB), source=0.0) if (segment%radiation) & @@ -3656,6 +3660,7 @@ subroutine deallocate_OBC_segment_data(segment) if (allocated(segment%Cg)) deallocate(segment%Cg) if (allocated(segment%Htot)) deallocate(segment%Htot) + if (allocated(segment%dZtot)) deallocate(segment%dZtot) if (allocated(segment%h)) deallocate(segment%h) if (allocated(segment%SSH)) deallocate(segment%SSH) if (allocated(segment%rx_norm_rad)) deallocate(segment%rx_norm_rad) @@ -3738,7 +3743,7 @@ subroutine open_boundary_test_extern_h(G, GV, OBC, h) if (.not. associated(OBC)) return - silly_h = GV%Z_to_H*OBC%silly_h + silly_h = GV%Z_to_H * OBC%silly_h do n = 1, OBC%number_of_segments do k = 1, GV%ke @@ -3789,6 +3794,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain integer :: ishift, jshift ! offsets for staggered locations + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units] real, dimension(:), allocatable :: h_stack ! Thicknesses at corner points [H ~> m or kg m-2] integer :: is_obc2, js_obc2 @@ -3822,6 +3828,11 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 endif + if (OBC%number_of_segments >= 1) then + call thickness_to_dz(h, tv, dz, G, GV, US) + call pass_var(dz, G%Domain) + endif + do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -3854,11 +3865,13 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed segment%Htot(I,j) = 0.0 + segment%dZtot(I,j) = 0.0 do k=1,GV%ke segment%h(I,j,k) = h(i+ishift,j,k) segment%Htot(I,j) = segment%Htot(I,j) + segment%h(I,j,k) + segment%dZtot(I,j) = segment%dZtot(I,j) + dz(i+ishift,j,k) enddo - segment%Cg(I,j) = sqrt(GV%g_prime(1)*segment%Htot(I,j)*GV%H_to_Z) + segment%Cg(I,j) = sqrt(GV%g_prime(1) * segment%dZtot(I,j)) enddo else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) allocate(normal_trans_bt(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB), source=0.0) @@ -3866,11 +3879,13 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied segment%Htot(i,J) = 0.0 + segment%dZtot(i,J) = 0.0 do k=1,GV%ke segment%h(i,J,k) = h(i,j+jshift,k) segment%Htot(i,J) = segment%Htot(i,J) + segment%h(i,J,k) + segment%dZtot(i,J) = segment%dZtot(i,J) + dz(i,j+jshift,k) enddo - segment%Cg(i,J) = sqrt(GV%g_prime(1)*segment%Htot(i,J)*GV%H_to_Z) + segment%Cg(i,J) = sqrt(GV%g_prime(1) * segment%dZtot(i,J)) enddo endif @@ -5623,8 +5638,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)*GV%H_to_Z + hTolerance) then - eta(i,j,k) = -segment%Htot(i,j)*GV%H_to_Z + if (-eta(i,j,k) > segment%dZtot(i,j) + hTolerance) then + eta(i,j,k) = -segment%dZtot(i,j) contractions = contractions + 1 endif enddo @@ -5642,10 +5657,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) * GV%H_to_Z) - hTolerance) then + if (-eta(i,j,nz+1) < segment%dZtot(i,j) - hTolerance) then dilations = dilations + 1 ! expand bottom-most cell only - eta(i,j,nz+1) = -(segment%Htot(i,j) * GV%H_to_Z) + eta(i,j,nz+1) = -segment%dZtot(i,j) segment%field(fld)%dz_src(i,j,nz)= eta(i,j,nz)-eta(i,j,nz+1) ! if (eta(i,j,1) <= eta(i,j,nz+1)) then ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo From e2deaecba3adc823dfca50f1edd2cb0c4e95652c Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 5 Oct 2023 11:32:15 -0400 Subject: [PATCH 107/146] *Patches for nonBous_OBCs to prevent blocking This adds logical tests to determine the global OBC data update patterns to allow for halo updates related to these updates without having the model hang up with inconsistently blocked message passing calls. This commit corrects a bug with some test cases that was introduced with the halo update after the call to thicknesses_to_dz in update_OBC_segment_data two commits previously. --- src/core/MOM_boundary_update.F90 | 2 +- src/core/MOM_open_boundary.F90 | 18 ++++++++++++++++-- .../MOM_state_initialization.F90 | 5 ++++- 3 files changed, 21 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 5a098cdf84..75f69dc779 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -156,7 +156,7 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, US, h, Time) if (CS%use_dyed_channel) & call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, US, Time) - if (OBC%needs_IO_for_data .or. OBC%add_tide_constituents) & + if (OBC%any_needs_IO_for_data .or. OBC%add_tide_constituents) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) end subroutine update_OBC_data diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index d32e947da1..896a677b02 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -278,7 +278,9 @@ module MOM_open_boundary logical :: update_OBC = .false. !< Is OBC data time-dependent logical :: update_OBC_seg_data = .false. !< Is it the time for OBC segment data update for fields that !! require less frequent update - logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs + logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs on the current PE + logical :: any_needs_IO_for_data = .false. !< Is any i/o needed for OBCs globally + logical :: some_need_no_IO_for_data = .false. !< Are there any PEs with OBCs that do not need i/o. logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero !! in the relative vorticity on open boundaries. @@ -736,6 +738,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) integer, dimension(1) :: single_pelist type(external_tracers_segments_props), pointer :: obgc_segments_props_list =>NULL() !will be able to dynamically switch between sub-sampling refined grid data or model grid + integer :: IO_needs(3) ! Sums to determine global OBC data use and update patterns. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1045,6 +1048,15 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) call Set_PElist(saved_pelist) + ! Determine global IO data requirement patterns. + IO_needs(1) = 0 ; if (OBC%needs_IO_for_data) IO_needs(1) = 1 + IO_needs(2) = 0 ; if (OBC%update_OBC) IO_needs(2) = 1 + IO_needs(3) = 0 ; if (.not.OBC%needs_IO_for_data) IO_needs(3) = 1 + call sum_across_PES(IO_needs, 3) + OBC%any_needs_IO_for_data = (IO_needs(1) > 0) + OBC%update_OBC = (IO_needs(2) > 0) + OBC%some_need_no_IO_for_data = (IO_needs(3) > 0) + end subroutine initialize_segment_data !> Return an appropriate dimensional scaling factor for input data based on an OBC segment data @@ -1909,7 +1921,7 @@ logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, a OBC%Flather_v_BCs_exist_globally if (present(apply_nudged_OBC)) open_boundary_query = OBC%nudged_u_BCs_exist_globally .or. & OBC%nudged_v_BCs_exist_globally - if (present(needs_ext_seg_data)) open_boundary_query = OBC%needs_IO_for_data + if (present(needs_ext_seg_data)) open_boundary_query = OBC%any_needs_IO_for_data end function open_boundary_query @@ -5755,6 +5767,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%brushcutter_mode = OBC_in%brushcutter_mode OBC%update_OBC = OBC_in%update_OBC OBC%needs_IO_for_data = OBC_in%needs_IO_for_data + OBC%any_needs_IO_for_data = OBC_in%any_needs_IO_for_data + OBC%some_need_no_IO_for_data = OBC_in%some_need_no_IO_for_data OBC%ntr = OBC_in%ntr diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 69d59961ec..4bddc0965a 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -18,6 +18,7 @@ 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, dz_to_thickness, dz_to_thickness_simple +use MOM_interface_heights, only : calc_derived_thermo use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data use MOM_open_boundary, only : OBC_NONE @@ -607,8 +608,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call initialize_segment_data(G, GV, US, OBC, PF) ! call open_boundary_config(G, US, PF, OBC) ! Call this once to fill boundary arrays from fixed values - if (.not. OBC%needs_IO_for_data) & + if (OBC%some_need_no_IO_for_data) then + call calc_derived_thermo(tv, h, G, GV, US) call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + endif call get_param(PF, mdl, "OBC_USER_CONFIG", config, & "A string that sets how the user code is invoked to set open boundary data: \n"//& From 3650339895f4da08394d0730be9c907abfe3c76a Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Sat, 7 Oct 2023 08:13:19 -0400 Subject: [PATCH 108/146] New treatment of ice shelf boundaries (#467) Previously, ice-shelf Dirichlet boundary conditions only allowed u-velocity and v-velocity to be set to the same value (which is enforced by setting the value of parameters u_face_mask or v_face_mask to 3). This functionality is retained here, but now setting u_face_mask or v_face_mask to 5 enforces a Dirichlet boundary for u-velocity only along the respective cell face. Similarly, setting u_face_mask or v_face_mask to 6 enforces the Dirichlet boundary for v-velocity only along the respective cell face. This functionality is required for most ice-sheet modeling configurations, e.g. the idealized MISMIP+ configuration requires setting v-velocity only to 0 along its lateral boundaries, but with free-slip conditions enforced for u-velocity. Adding this capability required changes throughout the ice-shelf code. Further changes were needed for how driving stress and Neummann conditions at computational boundaries are calculated in subroutine calc_shelf_driving_stress, and calls to subroutine apply_boundary_values were eliminated because they were not justified and caused errors. The new boundary treatment was tested by comparing simulated and analytical solutions for 1-D ice shelf flow with free-slip lateral boundary conditions and positive u_velocity enforced at the western boundary. This required the addition of a new parameter ADVECT_SHELF, which if false (as in the 1-D test case), turns off ice-shelf thickness evolution. By default, ADVECT_SHELF=True. The new boundary treatment was also justified in 2-D by correctly simulating the expected MISMIP+ steady-state. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 199 ++++++++++++--------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 2 +- 2 files changed, 120 insertions(+), 81 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index cefe251edd..98e2f3600b 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -54,11 +54,14 @@ module MOM_ice_shelf_dynamics !! not vertices. Will represent boundary conditions on computational boundary !! (or permanent boundary between fast-moving and near-stagnant ice !! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition, - !! 3=inhomogeneous Dirichlet boundary, 4=flux boundary: at these faces a flux - !! will be specified which will override velocities; a homogeneous velocity - !! condition will be specified (this seems to give the solver less difficulty) + !! 3=inhomogeneous Dirichlet boundary for u and v, 4=flux boundary: at these + !! faces a flux will be specified which will override velocities; a homogeneous + !! velocity condition will be specified (this seems to give the solver less + !! difficulty) 5=inhomogenous Dirichlet boundary for u only. 6=inhomogenous + !! Dirichlet boundary for v only real, pointer, dimension(:,:) :: v_face_mask => NULL() !< A mask for velocity boundary conditions on the C-grid - !! v-face, with valued defined similarly to u_face_mask. + !! v-face, with valued defined similarly to u_face_mask, but 5 is Dirichlet for v + !! and 6 is Dirichlet for u real, pointer, dimension(:,:) :: u_face_mask_bdry => NULL() !< A duplicate copy of u_face_mask? real, pointer, dimension(:,:) :: v_face_mask_bdry => NULL() !< A duplicate copy of v_face_mask? real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell @@ -118,6 +121,7 @@ module MOM_ice_shelf_dynamics real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. + logical :: advect_shelf !< If true (default), advect ice shelf and evolve thickness character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally !! according to Glen's flow law; is constant (for debugging purposes) !! or using observed strain rates and read from a file @@ -438,6 +442,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & "If true, do not allow an ice shelf where prohibited by a mask.", & default=.false.) + call get_param(param_file, mdl, "ADVECT_SHELF", CS%advect_shelf, & + "If true, advect ice shelf and evolve thickness", & + default=.true.) call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & "If MODEL, compute ice viscosity internally, if OBS read from a file,"//& "if CONSTANT a constant value (for debugging).", & @@ -491,17 +498,33 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! right hand side have not been set up yet. if (.not. G%symmetric) then do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + if ((i+G%idg_offset) == (G%domain%nihalo+1)) then + if (CS%u_face_mask(I-1,j) == 3) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + elseif (CS%u_face_mask(I-1,j) == 5) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + elseif (CS%u_face_mask(I-1,j) == 6) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + endif endif - if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,J-1) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + if ((j+G%jdg_offset) == (G%domain%njhalo+1)) then + if (CS%v_face_mask(i,J-1) == 3) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + elseif (CS%v_face_mask(i,J-1) == 5) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + elseif (CS%v_face_mask(i,J-1) == 6) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + endif endif enddo ; enddo endif @@ -702,7 +725,9 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled coupled_GL = .false. if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding ! - call ice_shelf_advect(CS, ISS, G, time_step, Time) + if (CS%advect_shelf) then + call ice_shelf_advect(CS, ISS, G, time_step, Time) + endif CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. @@ -864,8 +889,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i intent(out) :: taudx !< Driving x-stress at q-points [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] + !real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] + !real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. @@ -889,7 +914,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i rhoi_rhow = CS%density_ice / CS%density_ocean_avg taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 - u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 + !u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 Au(:,:) = 0.0 ; Av(:,:) = 0.0 ! need to make these conditional on GL interpolation @@ -959,8 +984,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo - call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0.0 ; Av(:,:) = 0.0 @@ -973,11 +998,13 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i err_init = 0 ; err_tempu = 0 ; err_tempv = 0 do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB if (CS%umask(I,J) == 1) then - err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + !err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_init) err_init = err_tempu endif if (CS%vmask(I,J) == 1) then - err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + !err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + err_tempv = ABS(Av(I,J) - taudy(I,J)) if (err_tempv >= err_init) err_init = err_tempv endif enddo ; enddo @@ -1013,10 +1040,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo - u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 + !u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + !call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 @@ -1032,11 +1059,13 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB if (CS%umask(I,J) == 1) then - err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + !err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_max) err_max = err_tempu endif if (CS%vmask(I,J) == 1) then - err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + !err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + err_tempv = ABS(Av(I,J) - taudy(I,J)) if (err_tempv >= err_max) err_max = err_tempv endif enddo ; enddo @@ -1138,10 +1167,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Zu_old, Zv_old, & ! Previous values of Zu and Zv [L T-1 ~> m s-1] DIAGu, DIAGv, & ! Diagonals with units like Ru/Zu [R L2 Z T-1 ~> kg s-1] RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] - ubd, vbd, & ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] - sum_vec, sum_vec_2 + sum_vec, sum_vec_2 !, & + !ubd, vbd ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] real :: beta_k, dot_p1, resid0, cg_halo real :: alpha_k ! A scaling factor for iterative corrections [nondim] real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] @@ -1163,7 +1192,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 ; RHSu(:,:) = 0 ; RHSv(:,:) = 0 - Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 !; ubd(:,:) = 0 ; vbd(:,:) = 0 dot_p1 = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. @@ -1177,11 +1206,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) - call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) + !call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + ! CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) - RHSu(:,:) = taudx(:,:) - ubd(:,:) - RHSv(:,:) = taudy(:,:) - vbd(:,:) + RHSu(:,:) = taudx(:,:) !- ubd(:,:) + RHSv(:,:) = taudy(:,:) !- vbd(:,:) call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) @@ -1792,6 +1821,7 @@ subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask +!> Calculate driving stress using cell-centered bed elevation and ice thickness subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe @@ -1817,10 +1847,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! "average" ocean depth -- and is needed to find surface elevation ! (it is assumed that base_ice = bed + OD) - real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation [Z ~> m]. - BASE ! basal elevation of shelf/stream [Z ~> m]. - real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S ! surface elevation [Z ~> m]. real :: rho, rhow, rhoi_rhow ! Ice and ocean densities [R ~> kg m-3] real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> nondim] @@ -1851,8 +1878,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) rhoi_rhow = rho/rhow ! prelim - go through and calculate S - ! or is this faster? - BASE(:,:) = -CS%bed_elev(:,:) + OD(:,:) S(:,:) = -CS%bed_elev(:,:) + ISS%h_shelf(:,:) ! check whether the ice is floating or grounded @@ -1867,10 +1892,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo call pass_var(S, G%domain) - allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) - do j=jscq,jecq ; do i=iscq,iecq - call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) - enddo ; enddo do j=jsc-1,jec+1 do i=isc-1,iec+1 @@ -1884,7 +1905,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell ! calculate sx - if ((i+i_off) == gisc) then ! at left computational bdry + if ((i+i_off) == gisc) then ! at west computational bdry if (ISS%hmask(i+1,j) == 1) then sx = (S(i+1,j)-S(i,j))/dxh else @@ -1927,7 +1948,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) else sy = 0 endif - elseif ((j+j_off) == gjec) then ! at nprth computational bdry + elseif ((j+j_off) == gjec) then ! at north computational bdry if (ISS%hmask(i,j-1) == 1) then sy = (S(i,j)-S(i,j-1))/dyh else @@ -1956,32 +1977,34 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif ! SW vertex - if (ISS%hmask(I-1,J-1) == 1) then + !if (ISS%hmask(I-1,J-1) == 1) then taudx(I-1,J-1) = taudx(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) taudy(I-1,J-1) = taudy(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - endif + !endif ! SE vertex - if (ISS%hmask(I,J-1) == 1) then + !if (ISS%hmask(I,J-1) == 1) then taudx(I,J-1) = taudx(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) taudy(I,J-1) = taudy(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - endif + !endif ! NW vertex - if (ISS%hmask(I-1,J) == 1) then + !if (ISS%hmask(I-1,J) == 1) then taudx(I-1,J) = taudx(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) taudy(I-1,J) = taudy(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - endif + !endif ! NE vertex - if (ISS%hmask(I,J) == 1) then + !if (ISS%hmask(I,J) == 1) then taudx(I,J) = taudx(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) taudy(I,J) = taudy(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - endif + !endif + + !Stress (Neumann) boundary conditions if (CS%ground_frac(i,j) == 1) then neumann_val = (.5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) else neumann_val = (.5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2) endif - - if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then + if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. & + ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (i+i_off .ne. gisc))) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated ! pressure on either side of the face @@ -1995,19 +2018,22 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) taudx(I-1,J) = taudx(I-1,J) - .5 * dyh * neumann_val endif - if ((CS%u_face_mask_bdry(I,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then + if ((CS%u_face_mask_bdry(I,j) == 2) .OR. & + ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (i+i_off .ne. giec))) then ! east face of the cell is at a stress boundary taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif - if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then + if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. & + ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (j+j_off .ne. gjsc))) then ! south face of the cell is at a stress boundary taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val endif - if ((CS%v_face_mask_bdry(i,J) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then + if ((CS%v_face_mask_bdry(i,J) == 2) .OR. & + ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (j+j_off .ne. gjec))) then ! north face of the cell is at a stress boundary taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val @@ -2017,9 +2043,9 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo enddo - deallocate(Phi) end subroutine calc_shelf_driving_stress +! Not used? Seems to be only set up to work for a specific test case with u_face_mask==3 subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) type(ice_shelf_dyn_CS),intent(inout) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. @@ -2385,6 +2411,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi if (CS%umask(Itgt,Jtgt) == 1) then u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) + endif + if (CS%vmask(Itgt,Jtgt) == 1) then v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo @@ -2481,10 +2509,11 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then ! process this cell if any corners have umask set to non-dirichlet bdry. - ! NOTE: vmask not considered, probably should be if ((CS%umask(I-1,J-1) == 3) .OR. (CS%umask(I,J-1) == 3) .OR. & - (CS%umask(I-1,J) == 3) .OR. (CS%umask(I,J) == 3)) then + (CS%umask(I-1,J) == 3) .OR. (CS%umask(I,J) == 3) .OR. & + (CS%vmask(I-1,J-1) == 3) .OR. (CS%vmask(I,J-1) == 3) .OR. & + (CS%vmask(I-1,J) == 3) .OR. (CS%vmask(I,J) == 3)) then call bilinear_shape_fn_grid(G, i, j, Phi) @@ -2972,7 +3001,7 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: vmask !< A coded mask indicating the nature of the !! meridional flow at the corner point -real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face @@ -2983,11 +3012,9 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face integer :: i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec - integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - i_off = G%idg_offset ; j_off = G%jdg_offset isd = G%isd ; jsd = G%jsd iegq = G%iegB ; jegq = G%jegB gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo @@ -3002,61 +3029,73 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face is = isd+1 ; js = jsd+1 endif + do j=js,G%jed; do i=is,G%ied + if (hmask(i,j) == 1) then + umask(I-1:I,J-1:J)=1 + vmask(I-1:I,J-1:J)=1 + endif + enddo; enddo + do j=js,G%jed do i=is,G%ied if ((hmask(i,j) == 1) .OR. (hmask(i,j) == 3)) then - umask(I,j) = 1. - vmask(I,j) = 1. - do k=0,1 select case (int(CS%u_face_mask_bdry(I-1+k,j))) + case (5) + umask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 5. case (3) - vmask(I-1+k,J-1) = 3. + umask(I-1+k,J-1:J) = 3. + vmask(I-1+k,J-1:J) = 3. u_face_mask(I-1+k,j) = 3. - umask(I-1+k,J) = 3. - vmask(I-1+k,J) = 3. - vmask(I-1+k,J) = 3. + case (6) + vmask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 6. case (2) u_face_mask(I-1+k,j) = 2. case (4) umask(I-1+k,J-1:J) = 0. - vmask(I-1+k,J-1:J) = 0. u_face_mask(I-1+k,j) = 4. case (0) umask(I-1+k,J-1:J) = 0. - vmask(I-1+k,J-1:J) = 0. u_face_mask(I-1+k,j) = 0. case (1) ! stress free x-boundary umask(I-1+k,J-1:J) = 0. case default + umask(I-1+k,J-1) = max(1. , umask(I-1+k,J-1)) + umask(I-1+k,J) = max(1. , umask(I-1+k,J)) end select enddo do k=0,1 select case (int(CS%v_face_mask_bdry(i,J-1+k))) + case (5) + vmask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 5. case (3) - vmask(I-1,J-1+k) = 3. - umask(I-1,J-1+k) = 3. - vmask(I,J-1+k) = 3. - umask(I,J-1+k) = 3. + vmask(I-1:I,J-1+k) = 3. + umask(I-1:I,J-1+k) = 3. v_face_mask(i,J-1+k) = 3. + case (6) + umask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 6. case (2) v_face_mask(i,J-1+k) = 2. case (4) - umask(I-1:I,J-1+k) = 0. vmask(I-1:I,J-1+k) = 0. v_face_mask(i,J-1+k) = 4. case (0) - umask(I-1:I,J-1+k) = 0. vmask(I-1:I,J-1+k) = 0. v_face_mask(i,J-1+k) = 0. case (1) ! stress free y-boundary vmask(I-1:I,J-1+k) = 0. case default + vmask(I-1,J-1+k) = max(1. , vmask(I-1,J-1+k)) + vmask(I,J-1+k) = max(1. , vmask(I,J-1+k)) end select enddo diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index dce6e53982..20a48730f3 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -351,7 +351,7 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b hmask(i+1,j) = 3.0 h_bdry_val(i+1,j) = h_shelf(i+1,j) thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) - u_face_mask_bdry(i+1,j) = 3.0 + u_face_mask_bdry(i+1,j) = 5.0 u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution endif From c39937240abb3ae965485b70fef13bb07182d690 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 6 Oct 2023 14:14:18 -0400 Subject: [PATCH 109/146] .testing: Codecov token for unit test upload The codecov token was added to the tc* test upload, but not the unit test upload. This patch adds the token to the unit testing. --- .github/workflows/coverage.yml | 4 ++++ .testing/Makefile | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index a54fda32a6..ad15989475 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -28,10 +28,14 @@ jobs: - name: Report unit test coverage to CI (PR) if: github.event_name == 'pull_request' run: make report.cov.unit REQUIRE_COVERAGE_UPLOAD=true + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - name: Report unit test coverage to CI (Push) if: github.event_name != 'pull_request' run: make report.cov.unit + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - name: Compile ocean-only MOM6 with code coverage run: make -j build/cov/MOM6 diff --git a/.testing/Makefile b/.testing/Makefile index c2ab27741a..b11532f93c 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -698,7 +698,7 @@ build/unit/MOM_file_parser_tests.F90.gcov: $(WORKSPACE)/work/unit/std.out .PHONY: report.cov.unit report.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov codecov - ./codecov -R build/unit -f "*.gcov" -Z -n "Unit tests" \ + ./codecov $(CODECOV_TOKEN_ARG) -R build/unit -f "*.gcov" -Z -n "Unit tests" \ > build/unit/codecov.out \ 2> build/unit/codecov.err \ && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ From 23345f0d82c59b9c3c223316d99c79449c1b6031 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 6 Oct 2023 17:37:14 -0400 Subject: [PATCH 110/146] *Fix non-Boussinesq Flather BT_OBC%dZ_v bug Corrected the non-Boussinesq calculation of the total depth used by the v-component of the Flather open boundary condition, making the v-component consistent with the u-component and correcting an oversight with a recent commit. This commit could change answers in some non-Boussinesq cases with Flather open boundary conditions. --- src/core/MOM_barotropic.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 4a5dba294a..21c3e64488 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -3335,9 +3335,9 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS endif else if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%dZ_v(i,J) = GV%H_to_Z*eta(i,j) + BT_OBC%dZ_v(i,J) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%dZ_v(i,J) = GV%H_to_Z*eta(i,j+1) + BT_OBC%dZ_v(i,J) = GV%H_to_RZ * eta(i,j+1) * SpV_avg(i,j+1) endif endif BT_OBC%Cg_v(i,J) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_v(i,J)) From 41609c2a233c4817237d24eb5334a637bac7ba2b Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Tue, 10 Oct 2023 17:47:28 -0400 Subject: [PATCH 111/146] Modify quadrature used for ice shelf viscosity (#468) Previously, when ice_viscosity_compute == MODEL, ice shelf viscosity was calculated using 1 quadrature point per cell; however, this quadrature point was not centered in the cell. -Added a routine bilinear_shape_fn_grid_1qp, which is used to instead calculate viscosity for a single cell-centered quadrature point -Added an option to define parameter ice_viscosity_compute = MODEL_QUADRATURE, where viscosity is calculated at the same four quadrature points used during the SSA solution (the typical approach in finite element codes). Note that when using one quadrature point (ice_viscosity_compute == MODEL), array ice_visc(:,:) is the cell-centered ice viscosity. When using four quadrature points (ice_viscosity_compute == MODEL_QUADRATURE), ice_visc(:,:) is the cell-centered ice viscosity divided by the effective stress, Ee, which varies between each quadrature point and is saved in a separate array CS%Ee(:,:,:). In the SSA, ice viscosity is calculated for a cell with indices i,j as ice_visc(i,j) * Ee, where Ee=1 if using one quadrature point for viscosity and Ee=CS%Ee(i,j,k) if using four quad points (where k the current quad point). Also note the post_data call for ice_visc when using four quad points, where Ice_visc is outputted for visualization from a cell as ice_visc(i,j)*Ee_av(i,j), where Ee_av(i,j) is the average Ee in the cell. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 264 ++++++++++++++++------- 1 file changed, 192 insertions(+), 72 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 98e2f3600b..bb9de629f7 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -82,6 +82,7 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity (Pa s), !! in [R L2 T-1 ~> kg m-1 s-1]. + real, pointer, dimension(:,:,:) :: Ee => NULL() !< Glen's effective strain-rate ** (1-n)/(n) real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, !! often in [Pa-3 s-1] if n_Glen is 3. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. @@ -273,6 +274,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate(CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0) allocate(CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing) ! [C ~> degC] allocate(CS%ice_visc(isd:ied,jsd:jed), source=0.0) + allocate(CS%Ee(isd:ied,jsd:jed,4), source=0.0) allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L2 T-2 ~> Pa] allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] @@ -446,7 +448,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "If true, advect ice shelf and evolve thickness", & default=.true.) call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & - "If MODEL, compute ice viscosity internally, if OBS read from a file,"//& + "If MODEL, compute ice viscosity internally at cell centers, if OBS read from a file,"//& + "If MODEL_QUADRATURE, compute at quadrature points (4 per element),"//& "if CONSTANT a constant value (for debugging).", & default="MODEL") @@ -538,6 +541,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%C_basal_friction, G%domain) call pass_var(CS%h_bdry_val, G%domain) call pass_var(CS%thickness_bdry_val, G%domain) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) @@ -762,6 +766,10 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) if (CS%id_visc_shelf > 0) then ice_visc(:,:) = CS%ice_visc(:,:)*G%IareaT(:,:) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") then + ice_visc(:,:) = ice_visc(:,:) * & + 0.25 * (CS%Ee(:,:,1) + CS%Ee(:,:,2) + CS%Ee(:,:,3) + CS%Ee(:,:,4)) + endif call post_data(CS%id_visc_shelf, ice_visc, CS%diag) endif if (CS%id_taub > 0) then @@ -977,6 +985,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call pass_var(CS%ice_visc, G%domain) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied @@ -989,7 +998,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i Au(:,:) = 0.0 ; Av(:,:) = 0.0 - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) @@ -1033,6 +1042,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call pass_var(CS%ice_visc, G%domain) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) + ! makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied @@ -1047,7 +1058,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) @@ -1219,7 +1230,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) @@ -1273,7 +1284,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + call CG_action(CS, Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, is, ie, js, je, rhoi_rhow) @@ -2115,9 +2126,10 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new end subroutine init_boundary_values -subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & +subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. @@ -2191,9 +2203,12 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt real, dimension(2) :: xquad real, dimension(2,2) :: Ucell, Vcell, Hcell, Usub, Vsub + real :: Ee xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + Ee=1.0 + do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1) then do iq=1,2 ; do jq=1,2 @@ -2228,11 +2243,13 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") Ee = CS%Ee(i,j,2*(jq-1)+iq) + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; ;Jtgt = J-2+jphi - if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & + if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + 0.25 * Ee * ice_visc(i,j) * & ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) - if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & + if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + 0.25 * Ee * ice_visc(i,j) * & ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) @@ -2352,11 +2369,14 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real, dimension(2) :: xquad real, dimension(2,2) :: Hcell, sub_ground integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt + real :: Ee isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + Ee=1.0 + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then call bilinear_shape_fn_grid(G, i, j, Phi) @@ -2364,46 +2384,52 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - do iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi - ilq = 1 ; if (iq == iphi) ilq = 2 - jlq = 1 ; if (jq == jphi) jlq = 2 + do iq=1,2 ; do jq=1,2 + + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") Ee = CS%Ee(i,j,2*(jq-1)+iq) + do iphi=1,2 ; do jphi=1,2 - if (CS%umask(Itgt,Jtgt) == 1) then + Itgt = I-2+iphi ; Jtgt = J-2+jphi + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 2 - ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - vx = 0. - vy = 0. + if (CS%umask(Itgt,Jtgt) == 1) then - u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + vx = 0. + vy = 0. - if (float_cond(i,j) == 0) then - uq = xquad(ilq) * xquad(jlq) u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) - endif - endif + 0.25 * Ee * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - if (CS%vmask(Itgt,Jtgt) == 1) then + if (float_cond(i,j) == 0) then + uq = xquad(ilq) * xquad(jlq) + u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) + endif + endif - vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - ux = 0. - uy = 0. + if (CS%vmask(Itgt,Jtgt) == 1) then - v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + ux = 0. + uy = 0. - if (float_cond(i,j) == 0) then - vq = xquad(ilq) * xquad(jlq) v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * Ee * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + if (float_cond(i,j) == 0) then + vq = xquad(ilq) * xquad(jlq) + v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) + endif endif - endif - enddo ; enddo ; enddo ; enddo + enddo ; enddo + enddo ; enddo if (float_cond(i,j) == 1) then Hcell(:,:) = H_node(i-1:i,j-1:j) @@ -2501,11 +2527,14 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq, Itgt, Jtgt + real :: Ee isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + Ee=1.0 + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then ! process this cell if any corners have umask set to non-dirichlet bdry. @@ -2552,13 +2581,15 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, CS%v_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & CS%v_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") Ee = CS%Ee(i,j,2*(jq-1)+iq) + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 if (CS%umask(Itgt,Jtgt) == 1) then u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * Ee * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then @@ -2569,7 +2600,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, if (CS%vmask(Itgt,Jtgt) == 1) then v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * Ee * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then @@ -2615,7 +2646,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, pointer, dimension(:,:,:) :: PhiC => NULL() ! Same as Phi, but 1 quadrature point per cell (rather than 4) + ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve @@ -2638,11 +2671,17 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset - allocate(Phi(1:8,1:4,isc:iec,jsc:jec), source=0.0) - - do j=jsc,jec ; do i=isc,iec - call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) - enddo ; enddo + if (trim(CS%ice_viscosity_compute) == "MODEL") then + allocate(PhiC(1:8,isc:iec,jsc:jec), source=0.0) + do j=jsc,jec ; do i=isc,iec + call bilinear_shape_fn_grid_1qp(G, i, j, PhiC(:,i,j)) + enddo; enddo + elseif (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") then + allocate(Phi(1:8,1:4,isc:iec,jsc:jec), source=0.0) + do j=jsc,jec ; do i=isc,iec + call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) + enddo; enddo + endif n_g = CS%n_glen; eps_min = CS%eps_glen_min CS%ice_visc(:,:) = 1.0e22 @@ -2650,43 +2689,79 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) do j=jsc,jec ; do i=isc,iec if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then - Visc_coef = ( (US%RL2_T2_to_Pa)**(-CS%n_glen)*US%T_to_s )**(-1./CS%n_glen) * (CS%AGlen_visc(i,j))**(-1./CS%n_glen) - ! Units of Aglen_visc [Pa-3 s-1] - do iq=1,2 ; do jq=1,2 - ux = ( (u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j)) + & - (u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j)) ) - - vx = ( (v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j)) + & - (v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j)) ) - - uy = ( (u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j)) + & - (u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) - - vy = ( (v_shlf(I-1,j-1) * Phi(2,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j)) + & - (v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) - enddo ; enddo if (trim(CS%ice_viscosity_compute) == "CONSTANT") then CS%ice_visc(i,j) = 1e15 * US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T * (G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging - elseif (trim(CS%ice_viscosity_compute) == "MODEL") then - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & - (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) elseif (trim(CS%ice_viscosity_compute) == "OBS") then if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j) = CS%AGlen_visc(i,j)*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! Here CS%Aglen_visc(i,j) is the ice viscocity [Pa s-1] computed from obs and read from a file + elseif (trim(CS%ice_viscosity_compute) == "MODEL") then + + Visc_coef = ( (US%RL2_T2_to_Pa)**(-CS%n_glen)*US%T_to_s )**(-1./CS%n_glen) * & + (CS%AGlen_visc(i,j))**(-1./CS%n_glen) + ! Units of Aglen_visc [Pa-3 s-1] + + ux = u_shlf(I-1,J-1) * PhiC(1,i,j) + & + u_shlf(I,J) * PhiC(7,i,j) + & + u_shlf(I-1,J) * PhiC(5,i,j) + & + u_shlf(I,J-1) * PhiC(3,i,j) + + vx = v_shlf(I-1,J-1) * PhiC(1,i,j) + & + v_shlf(I,J) * PhiC(7,i,j) + & + v_shlf(I-1,J) * PhiC(5,i,j) + & + v_shlf(I,J-1) * PhiC(3,i,j) + + uy = u_shlf(I-1,J-1) * PhiC(2,i,j) + & + u_shlf(I,J) * PhiC(8,i,j) + & + u_shlf(I-1,J) * PhiC(6,i,j) + & + u_shlf(I,J-1) * PhiC(4,i,j) + + vy = v_shlf(I-1,J-1) * PhiC(2,i,j) + & + v_shlf(I,J) * PhiC(8,i,j) + & + v_shlf(I-1,J) * PhiC(6,i,j) + & + v_shlf(I,J-1) * PhiC(4,i,j) + + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + elseif (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") then + !in this case, we will compute viscosity at quadrature points within subroutines CG_action + !and apply_boundary_values. CS%ice_visc(i,j) will include everything except the effective strain rate term: + Visc_coef = ( (US%RL2_T2_to_Pa)**(-CS%n_glen)*US%T_to_s )**(-1./CS%n_glen) * & + (CS%AGlen_visc(i,j))**(-1./CS%n_glen) + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) + + do iq=1,2 ; do jq=1,2 + + ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & + u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) + + vx = v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & + v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) + + uy = u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & + u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) + + vy = v_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & + v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) + + CS%Ee(i,j,2*(jq-1)+iq) = & + (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + enddo; enddo endif endif enddo ; enddo - deallocate(Phi) + + if (trim(CS%ice_viscosity_compute) == "MODEL") deallocate(PhiC) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") deallocate(Phi) end subroutine calc_shelf_visc @@ -2937,6 +3012,50 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) end subroutine bilinear_shape_fn_grid +!> This subroutine calculates the gradients of bilinear basis elements that are centered at the +!! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at +!! a sinlge cell-centered quadrature point, which should match the grid cell h-point +subroutine bilinear_shape_fn_grid_1qp(G, i, j, Phi) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + integer, intent(in) :: i !< The i-index in the grid to work on. + integer, intent(in) :: j !< The j-index in the grid to work on. + real, dimension(8), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + +! This subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. The values are calculated at +! a cell-cented point of gaussian quadrature. (in 1D: .5 for [0,1]) +! (ordered in same way as vertices) +! +! Phi(2*i-1) gives d(Phi_i)/dx at the quadrature point +! Phi(2*i) gives d(Phi_i)/dy at the quadrature point +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear + + real :: a, d ! Interpolated grid spacings [L ~> m] + real :: xexp=0.5, yexp=0.5 ! [nondim] + integer :: node, qpoint, xnode, ynode + + ! d(x)/d(x*) + if (J>1) then + a = 0.5 * (G%dxCv(i,J-1) + G%dxCv(i,J)) + else + a = G%dxCv(i,J) + endif + + ! d(y)/d(y*) + if (I>1) then + d = 0.5 * (G%dyCu(I-1,j) + G%dyCu(I,j)) + else + d = G%dyCu(I,j) + endif + + do node=1,4 + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + Phi(2*node-1) = ( d * (2 * xnode - 3) * yexp ) / (a*d) + Phi(2*node) = ( a * (2 * ynode - 3) * xexp ) / (a*d) + enddo +end subroutine bilinear_shape_fn_grid_1qp + subroutine bilinear_shape_functions_subgrid(Phisub, nsub) integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction @@ -3201,6 +3320,7 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%umask, CS%vmask) deallocate(CS%ice_visc, CS%AGlen_visc) + deallocate(CS%Ee) deallocate(CS%basal_traction,CS%C_basal_friction) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%t_bdry_val, CS%bed_elev) From 2ac48a63d81405128688a8cce08c0de0448846af Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Wed, 11 Oct 2023 04:14:12 -0400 Subject: [PATCH 112/146] SSA convergence based on change of norm (#469) Added an option NONLIN_SOLVE_ERR_MODE=3 to check for convergence of the ice shelf SSA solution by testing the change of norm, i.e. 2*abs(|u_{t}|-|u_{t-1}|) / (|u_{t}|+|u_{t-1}|) --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 70 +++++++++++++++++------- 1 file changed, 50 insertions(+), 20 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index bb9de629f7..f4eacbb666 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -160,6 +160,7 @@ module MOM_ice_shelf_dynamics integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver integer :: nonlin_solve_err_mode !< 1: exit vel solve based on nonlin residual !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm + !! 3: exit based on change of norm ! ids for outputting intermediate thickness in advection subroutine (debugging) !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 @@ -436,7 +437,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ units="m", default=1.e-3, scale=US%m_to_Z) call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & "Choose whether nonlin error in vel solve is based on nonlinear "//& - "residual (1) or relative change since last iteration (2)", default=1) + "residual (1), relative change since last iteration (2), or change in norm (3)", default=1) call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & "Specify whether to advance shelf front (and calve).", & @@ -904,15 +905,17 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice ! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Used for convergence character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv + real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv, Norm, PrevNorm real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] + integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. ! for GL interpolation nsub = CS%n_sub_regularize @@ -993,17 +996,17 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo + if (CS%nonlin_solve_err_mode == 1) then ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) - Au(:,:) = 0.0 ; Av(:,:) = 0.0 + Au(:,:) = 0.0 ; Av(:,:) = 0.0 - call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & - G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - if (CS%nonlin_solve_err_mode == 1) then err_init = 0 ; err_tempu = 0 ; err_tempv = 0 do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB if (CS%umask(I,J) == 1) then @@ -1019,6 +1022,24 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo ; enddo call max_across_PEs(err_init) + elseif (CS%nonlin_solve_err_mode == 3) then + Normvec=0.0 + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. + Is_sum = G%isc + (1-G%IsdB) + Ie_sum = G%iecB + (1-G%IsdB) + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) + + Js_sum = G%jsc + (1-G%JsdB) + Je_sum = G%jecB + (1-G%JsdB) + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)*u_shlf(I,J) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)*v_shlf(I,J) + enddo; enddo + Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) + Norm = sqrt(Norm) endif u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:) @@ -1051,22 +1072,21 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo - !u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - - !call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + if (CS%nonlin_solve_err_mode == 1) then + !u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - Au(:,:) = 0 ; Av(:,:) = 0 + ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) - call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & - G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + Au(:,:) = 0 ; Av(:,:) = 0 - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - err_max = 0 + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - if (CS%nonlin_solve_err_mode == 1) then + err_max = 0 do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB if (CS%umask(I,J) == 1) then @@ -1085,7 +1105,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i elseif (CS%nonlin_solve_err_mode == 2) then - max_vel = 0 ; tempu = 0 ; tempv = 0 + err_max=0. ; max_vel = 0 ; tempu = 0 ; tempv = 0 ; err_tempu = 0 do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB if (CS%umask(I,J) == 1) then err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) @@ -1108,6 +1128,16 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call max_across_PEs(max_vel) call max_across_PEs(err_max) err_init = max_vel + + elseif (CS%nonlin_solve_err_mode == 3) then + PrevNorm=Norm; Norm=0.0; Normvec=0.0 + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)*u_shlf(I,J) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)*v_shlf(I,J) + enddo; enddo + Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) + Norm = sqrt(Norm) + err_max=2.*abs(Norm-PrevNorm); err_init=Norm+PrevNorm endif write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init From bd4c87ce55469e82e42662ff332378b7c6ded9f0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Jul 2023 09:50:08 -0400 Subject: [PATCH 113/146] *Use thickness_to_dz in dumbbell_initialize_sponges Use thickness_to_dz to convert thicknesses from thickness units to height units in dumbbell_initialize_sponges with the traditional (non-ALE) sponges. Boussinesq answers are identical, but non-Boussinesq answers with an equation of state will change to be less dependent on the value of RHO_0. --- src/user/dumbbell_initialization.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index b2ed47f89b..492cb3ebe8 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -10,6 +10,7 @@ module dumbbell_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : dz_to_thickness, dz_to_thickness_simple +use MOM_interface_heights, only : thickness_to_dz use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS use MOM_tracer_registry, only : tracer_registry_type use MOM_unit_scaling, only : unit_scale_type @@ -472,10 +473,13 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & sp_long_name='salinity', sp_unit='g kg-1 s-1') else + ! Convert thicknesses from thickness units to height units + call thickness_to_dz(h_in, tv, dz, G, GV, US) + do j=G%jsc,G%jec ; do i=G%isc,G%iec eta(i,j,1) = 0.0 do k=2,nz - eta(i,j,k) = eta(i,j,k-1) - GV%H_to_Z * h_in(i,j,k-1) + eta(i,j,k) = eta(i,j,k-1) - dz(i,j,k-1) enddo eta(i,j,nz+1) = -depth_tot(i,j) do k=1,nz From 95d6e93604597fa8f780b395c5089a556672165f Mon Sep 17 00:00:00 2001 From: WenhaoChen89 <96131003+WenhaoChen89@users.noreply.github.com> Date: Thu, 12 Oct 2023 12:18:10 -0400 Subject: [PATCH 114/146] (+*) Fix bugs in tracer index in tracer reservoirs (#480) * Fix nudged OBCs for tracers * Fix index in tracer reservoirs * fix index in the function update_segment_tracer_reservoirs * Fix index bugs in OBC tracer reservoirs * Fix tracer index bugs at open boundaries --- src/core/MOM_open_boundary.F90 | 72 +++++++++++++++++------- src/tracer/MOM_tracer_advect.F90 | 54 ++++++++++-------- src/tracer/MOM_tracer_registry.F90 | 11 +++- src/user/DOME_initialization.F90 | 18 +++--- src/user/dyed_channel_initialization.F90 | 6 +- src/user/dyed_obcs_initialization.F90 | 6 +- 6 files changed, 104 insertions(+), 63 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 896a677b02..c995adb671 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -32,6 +32,7 @@ module MOM_open_boundary use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type +use MOM_string_functions, only : lowercase implicit none ; private @@ -118,6 +119,8 @@ module MOM_open_boundary real :: scale !< A scaling factor for converting the units of input !! data, like [S ppt-1 ~> 1] for salinity. logical :: is_initialized !< reservoir values have been set when True + integer :: ntr_index = -1 !< index of segment tracer in the global tracer registry + integer :: fd_index = -1 !< index of segment tracer in the input fields end type OBC_segment_tracer_type !> Registry type for tracers on segments @@ -4647,8 +4650,8 @@ end subroutine segment_tracer_registry_init !> Register a tracer array that is active on an OBC segment, potentially also specifying how the !! tracer inflow values are specified. -subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & - OBC_scalar, OBC_array, scale) +subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & + OBC_scalar, OBC_array, scale, fd_index) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(tracer_type), target :: tr_ptr !< A target that can be used to set a pointer to the !! stored value of tr. This target must be @@ -4657,6 +4660,7 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & !! but it also means that any updates to this !! structure in the calling module will be !! available subsequently to the tracer registry. + integer, intent(in) :: ntr_index !< index of segment tracer in the global tracer registry type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values type(OBC_segment_type), intent(inout) :: segment !< current segment data structure real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer @@ -4667,6 +4671,7 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & real, optional, intent(in) :: scale !< A scaling factor that should be used with any !! data that is read in, to convert it to the internal !! units of this tracer. + integer, optional, intent(in) :: fd_index !< index of segment tracer in the input field ! Local variables real :: rescale ! A multiplicative correction to the scaling factor. @@ -4690,6 +4695,8 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & segment%tr_Reg%Tr(ntseg)%Tr => tr_ptr segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name + segment%tr_Reg%Tr(ntseg)%ntr_index = ntr_index + if (present(fd_index)) segment%tr_Reg%Tr(ntseg)%fd_index = fd_index segment%tr_Reg%Tr(ntseg)%scale = 1.0 if (present(scale)) then @@ -4752,7 +4759,7 @@ subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values ! Local variables - integer :: n + integer :: n, ntr_id character(len=32) :: name type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list type(tracer_type), pointer :: tr_ptr => NULL() @@ -4767,12 +4774,12 @@ subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) call MOM_error(FATAL,"register_temp_salt_segments: tracer array was previously allocated") name = 'temp' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, & + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & OBC_array=segment%temp_segment_data_exists, scale=US%degC_to_C) name = 'salt' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, & + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & OBC_array=segment%salt_segment_data_exists, scale=US%ppt_to_S) enddo @@ -4825,8 +4832,8 @@ subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) 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 + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf, ntr_id, fd_id + integer :: i, j, k, n, m type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list type(tracer_type), pointer :: tr_ptr => NULL() @@ -4835,8 +4842,13 @@ subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) 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.) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, tr_name) + ! get the obgc field index + fd_id = -1 + do m=1,segment%num_fields + if (lowercase(segment%field(m)%name) == lowercase(tr_name)) fd_id = m + enddo + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, OBC_array=.True., fd_index=fd_id) enddo end subroutine register_obgc_segments @@ -5336,8 +5348,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) real :: fac1 ! The denominator of the expression for tracer updates [nondim] real :: I_scale ! The inverse of the scaling factor for the tracers. ! For salinity the units would be [ppt S-1 ~> 1] - integer :: i, j, k, m, n, ntr, nz + integer :: i, j, k, m, n, ntr, nz, ntr_id, fd_id integer :: ishift, idir, jshift, jdir + real :: resrv_lfac_out, resrv_lfac_in real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs ! 1 if the length scale of reservoir is zero [nondim] real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights @@ -5365,7 +5378,16 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! Can keep this or take it out, either way if (G%mask2dT(I+ishift,j) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + fd_id = segment%tr_reg%Tr(m)%fd_index + if(fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz ! Calculate weights. Both a and u_L are nodim. Adding them together has no meaning. @@ -5374,14 +5396,14 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs a_out = b_out * max(0.0, sign(1.0, idir*uhr(I,j,k))) a_in = b_in * min(0.0, sign(1.0, idir*uhr(I,j,k))) - u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out*segment%field(m)%resrv_lfac_out / & + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) - u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in*segment%field(m)%resrv_lfac_in / & + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) fac1 = (1.0 - (a_out - a_in)) + ((u_L_out + a_out) - (u_L_in + a_in)) segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1) * & ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(I,j,k)+ & - ((u_L_out+a_out)*Reg%Tr(m)%t(I+ishift,j,k) - & + ((u_L_out+a_out)*Reg%Tr(ntr_id)%t(I+ishift,j,k) - & (u_L_in+a_in)*segment%tr_Reg%Tr(m)%t(I,j,k))) if (allocated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) enddo ; endif @@ -5400,20 +5422,28 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! Can keep this or take it out, either way if (G%mask2dT(i,j+jshift) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + fd_id = segment%tr_reg%Tr(m)%fd_index + if(fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,J,k))) a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,J,k))) - v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out*segment%field(m)%resrv_lfac_out / & + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) - v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in*segment%field(m)%resrv_lfac_in / & + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) - fac1 = 1.0 + (v_L_out-v_L_in) fac1 = (1.0 - (a_out - a_in)) + ((v_L_out + a_out) - (v_L_in + a_in)) segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1) * & ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(i,J,k) + & - ((v_L_out+a_out)*Reg%Tr(m)%t(i,J+jshift,k) - & + ((v_L_out+a_out)*Reg%Tr(ntr_id)%t(i,J+jshift,k) - & (v_L_in+a_in)*segment%tr_Reg%Tr(m)%t(i,J,k))) if (allocated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) enddo ; endif diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index dde110f959..efe6397de0 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -381,7 +381,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. logical :: usePLMslope - integer :: i, j, m, n, i_up, stencil + integer :: i, j, m, n, i_up, stencil, ntr_id type(OBC_segment_type), pointer :: segment=>NULL() logical, dimension(SZJ_(G),SZK_(GV)) :: domore_u_initial @@ -442,18 +442,19 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (segment%is_E_or_W) then if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then I = segment%HI%IsdB - do m = 1,ntr ! replace tracers with OBC values + do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then if (segment%direction == OBC_DIRECTION_W) then - T_tmp(i,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i,ntr_id) = 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,ntr_id) = 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 + T_tmp(i,ntr_id) = 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,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -586,10 +587,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & (uhr(I,j,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_E)) then uhh(I) = uhr(I,j,k) ! should the reservoir evolve for this case Kate ?? - Nope - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else ; flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else ; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif endif @@ -609,10 +611,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if ((uhr(I,j,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & (uhr(I,j,k) < 0.0) .and. (G%mask2dT(i+1,j) < 0.5)) then uhh(I) = uhr(I,j,k) - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else; flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif enddo endif endif @@ -754,7 +757,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. logical :: do_i(SZIB_(G), SZJ_(G)) ! If true, work on given points. logical :: usePLMslope - integer :: i, j, j2, m, n, j_up, stencil + integer :: i, j, j2, m, n, j_up, stencil, ntr_id type(OBC_segment_type), pointer :: segment=>NULL() logical :: domore_v_initial(SZJB_(G)) ! Initial state of domore_v @@ -823,18 +826,19 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if (segment%is_N_or_S) then if (i>=segment%HI%isd .and. i<=segment%HI%ied) then J = segment%HI%JsdB - do m = 1,ntr ! replace tracers with OBC values + do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then if (segment%direction == OBC_DIRECTION_S) then - T_tmp(i,m,j) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - T_tmp(i,m,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif else if (segment%direction == OBC_DIRECTION_S) then - T_tmp(i,m,j) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%OBC_inflow_conc else - T_tmp(i,m,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -968,10 +972,11 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if ((vhr(i,J,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_S) .or. & (vhr(i,J,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_N)) then vhh(i,J) = vhr(i,J,k) - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) - else ; flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif enddo @@ -991,10 +996,11 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if ((vhr(i,J,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & (vhr(i,J,k) < 0.0) .and. (G%mask2dT(i,j+1) < 0.5)) then vhh(i,J) = vhr(i,J,k) - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_y(i,m,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) - else ; flux_y(i,m,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif enddo diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c3f5f64edf..1e9b9c22b8 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -848,16 +848,21 @@ end subroutine tracer_Reg_chkinv !> Find a tracer in the tracer registry by name. -subroutine tracer_name_lookup(Reg, tr_ptr, name) +subroutine tracer_name_lookup(Reg, n, tr_ptr, name) type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry type(tracer_type), pointer :: tr_ptr !< target or pointer to the tracer array character(len=32), intent(in) :: name !< tracer name + integer, intent(out) :: n !< index to tracer registery - integer n do n=1,Reg%ntr - if (lowercase(Reg%Tr(n)%name) == lowercase(name)) tr_ptr => Reg%Tr(n) + if (lowercase(Reg%Tr(n)%name) == lowercase(name)) then + tr_ptr => Reg%Tr(n) + return + endif enddo + call MOM_error(FATAL,"MOM cannot find registered tracer: "//name) + end subroutine tracer_name_lookup !> Initialize the tracer registry. diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 638ecf80db..858ca32f93 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -334,7 +334,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) ! region of the specified shear profile [nondim] character(len=32) :: name ! The name of a tracer field. character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, ntherm + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, ntherm, ntr_id integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() @@ -434,8 +434,8 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) if (associated(tv%S)) then ! In this example, all S inflows have values given by S_ref. name = 'salt' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, PF, GV, segment, OBC_scalar=S_ref, scale=US%ppt_to_S) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, segment, OBC_scalar=S_ref, scale=US%ppt_to_S) endif if (associated(tv%T)) then ! In this example, the T values are set to be consistent with the layer @@ -459,8 +459,8 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) segment%field(1)%buffer_src(i,j,k) = T0(k) enddo ; enddo ; enddo name = 'temp' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, PF, GV, segment, OBC_array=.true., scale=US%degC_to_C) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, segment, OBC_array=.true., scale=US%degC_to_C) endif ! Set up dye tracers @@ -472,16 +472,16 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) else ; segment%field(ntherm+1)%buffer_src(i,j,k) = 1.0 ; endif enddo ; enddo ; enddo name = 'tr_D1' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, PF, GV, OBC%segment(1), OBC_array=.true.) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1), OBC_array=.true.) ! All tracers but the first have 0 concentration in their inflows. As 0 is the ! default value for the inflow concentrations, the following calls are unnecessary. do m=2,tr_Reg%ntr if (m < 10) then ; write(name,'("tr_D",I1.1)') m else ; write(name,'("tr_D",I2.2)') m ; endif - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, PF, GV, OBC%segment(1), OBC_scalar=0.0) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1), OBC_scalar=0.0) enddo end subroutine DOME_set_OBC_data diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index aed7142fad..2dde65148b 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -93,7 +93,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) ! Local variables character(len=40) :: mdl = "dyed_channel_set_OBC_tracer_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: m, n + integer :: m, n, ntr_id real :: dye ! Inflow dye concentrations [arbitrary] type(tracer_type), pointer :: tr_ptr => NULL() @@ -115,7 +115,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) do m=1,ntr write(name,'("dye_",I2.2)') m write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m - call tracer_name_lookup(tr_Reg, tr_ptr, name) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) do n=1,OBC%number_of_segments if (n == m) then @@ -123,7 +123,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) else dye = 0.0 endif - call register_segment_tracer(tr_ptr, param_file, GV, & + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, & OBC%segment(n), OBC_scalar=dye) enddo enddo diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 6248efab2f..7d1c0635f9 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -39,7 +39,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) ! Local variables character(len=40) :: mdl = "dyed_obcs_set_OBC_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz + integer :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz, ntr_id integer :: IsdB, IedB, JsdB, JedB real :: dye ! Inflow dye concentration [arbitrary] type(tracer_type), pointer :: tr_ptr => NULL() @@ -65,7 +65,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) do m=1,ntr write(name,'("dye_",I2.2)') m write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m - call tracer_name_lookup(tr_Reg, tr_ptr, name) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) do n=1,OBC%number_of_segments if (n == m) then @@ -73,7 +73,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) else dye = 0.0 endif - call register_segment_tracer(tr_ptr, param_file, GV, & + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, & OBC%segment(n), OBC_scalar=dye) enddo enddo From 38aeccd855350d29bf88e210ba01b6e61cb600ac Mon Sep 17 00:00:00 2001 From: Spencer Jones <41342785+cspencerjones@users.noreply.github.com> Date: Thu, 12 Oct 2023 19:14:13 -0500 Subject: [PATCH 115/146] +Add particle code option to advect with uhtr (#492) * +Add particle code option to advect with uhtr The particle code has so far used the same velocity has was used in the dynamics step. I would like to add the option for the particle code to use uhtr/h and vhtr/h, so that the velocities used to advect particles may include the effects of parameterized eddies. To make this work, I have added a flag that controls which velocity to use and moved the particles_run step to take place after uhtr and vhtr are defined. The interfaces in the code and in config_src/external are updated to pass this information to the drifters package. --- .../external/drifters/MOM_particles.F90 | 11 ++++++++--- src/core/MOM.F90 | 19 ++++++++++++++----- 2 files changed, 22 insertions(+), 8 deletions(-) diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index fa3840c6c2..b86c720b75 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -28,14 +28,19 @@ subroutine particles_init(parts, Grid, Time, dt, u, v, h) end subroutine particles_init !> The main driver the steps updates particles -subroutine particles_run(parts, time, uo, vo, ho, tv, stagger) +subroutine particles_run(parts, time, uo, vo, ho, tv, use_uh, stagger) ! Arguments type(particles), pointer :: parts !< Container for all types and memory type(time_type), intent(in) :: time !< Model time - real, dimension(:,:,:), intent(in) :: uo !< Ocean zonal velocity [L T-1 ~>m s-1] - real, dimension(:,:,:), intent(in) :: vo !< Ocean meridional velocity [L T-1~> m s-1] + real, dimension(:,:,:), intent(in) :: uo !< If use_uh is false, ocean zonal velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated zonal thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] + real, dimension(:,:,:), intent(in) :: vo !< If use_uh is false, ocean meridional velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated meridional thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] real, dimension(:,:,:), intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields + logical :: use_uh !< Flag for whether u and v are weighted by thickness integer, optional, intent(in) :: stagger !< Flag for whether velocities are staggered end subroutine particles_run diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 25f4f27ee7..2af9ad40e1 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -360,6 +360,7 @@ module MOM !! higher values use more appropriate expressions that differ at !! roundoff for non-Boussinesq cases. logical :: use_particles !< Turns on the particles package + logical :: use_uh_particles !< particles are advected by uh/h logical :: use_dbclient !< Turns on the database client used for ML inference/analysis character(len=10) :: particle_type !< Particle types include: surface(default), profiling and sail drone. @@ -1266,10 +1267,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & enddo; enddo endif - if (CS%use_particles .and. CS%do_dynamics) then ! Run particles whether or not stepping is split - call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, CS%tv) ! Run the particles model - endif - if ((CS%thickness_diffuse .or. CS%interface_filter) .and. & .not.CS%thickness_diffuse_first) then @@ -1331,6 +1328,17 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif call disable_averaging(CS%diag) + if (CS%use_particles .and. CS%do_dynamics .and. CS%use_uh_particles) then + !Run particles using thickness-weighted velocity + call particles_run(CS%particles, Time_local, CS%uhtr, CS%vhtr, CS%h, & + CS%tv, CS%use_uh_particles) + elseif (CS%use_particles .and. CS%do_dynamics) then + !Run particles using unweighted velocity + call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, & + CS%tv, CS%use_uh_particles) + endif + + ! Advance the dynamics time by dt. CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt CS%n_dyn_steps_in_adv = CS%n_dyn_steps_in_adv + 1 @@ -2440,7 +2448,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "USE_PARTICLES", CS%use_particles, & "If true, use the particles package.", default=.false.) - + call get_param(param_file, "MOM", "USE_UH_PARTICLES", CS%use_uh_particles, & + "If true, use the uh velocity in the particles package.",default=.false.) CS%ensemble_ocean=.false. call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, & "If False, The model is being run in serial mode as a single realization. "//& From 89506fab00d2f73a57f498e4b7fbd8edfbfe1378 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Fri, 13 Oct 2023 00:09:37 -0400 Subject: [PATCH 116/146] Ice shelf Coulomb friction law (#470) * Added ice shelf Coulomb friction law (Schoof 2005, Gagliardini et al 2007) needed for MISMIP+ experiments (Asay-Davis et al 2016). --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 72 +++++++++++++++++++----- 1 file changed, 57 insertions(+), 15 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index f4eacbb666..81a4c7e21b 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -98,11 +98,12 @@ module MOM_ice_shelf_dynamics !! the same as G%bathyT+Z_ref, when below sea-level. !! Sign convention: positive below sea-level, negative above. - real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" - !! basal stress (Pa) [R L2 T-2 ~> Pa]. + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area-integrated taub_beta field + !! (m2 Pa s m-1, or kg s-1) related to the nonlinear part + !! of "linearized" basal stress (Pa) [R L3 T-1 ~> kg s-1] !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), - !! units= Pa (m yr-1)-(n_basal_fric) + !! units= Pa (m s-1)^(n_basal_fric) real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av [Z ~> m]. real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. @@ -144,6 +145,10 @@ module MOM_ice_shelf_dynamics real :: n_glen !< Nonlinearity exponent in Glen's Law [nondim] real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [T-1 ~> s-1]. real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) [nondim] + logical :: CoulombFriction !< Use Coulomb friction law (Schoof 2005, Gagliardini et al 2007) + real :: CF_MinN !< Minimum Coulomb friction effective pressure [R L2 T-2 ~> Pa] + real :: CF_PostPeak !< Coulomb friction post peak exponent [nondim] + real :: CF_Max !< Coulomb friction maximum coefficient [nondim] real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean !! circulation or thermodynamics. It is used to estimate the !! gravitational driving force at the shelf front (until we think of @@ -277,7 +282,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate(CS%ice_visc(isd:ied,jsd:jed), source=0.0) allocate(CS%Ee(isd:ied,jsd:jed,4), source=0.0) allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] - allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L2 T-2 ~> Pa] + allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L3 T-1 ~> kg s-1] allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) @@ -423,6 +428,19 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "USE_COULOMB_FRICTION", CS%CoulombFriction, & + "Use Coulomb Friction Law", & + units="none", default=.false., fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_MinN", CS%CF_MinN, & + "Minimum Coulomb friction effective pressure", & + units="Pa", default=1.0, scale=US%Pa_to_RL2_T2, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_PostPeak", CS%CF_PostPeak, & + "Coulomb friction post peak exponent", & + units="none", default=1.0, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_Max", CS%CF_Max, & + "Coulomb friction maximum coefficient", & + units="none", default=0.5, fail_if_missing=.false.) + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & @@ -624,7 +642,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & 'vi-viscosity', 'Pa m s', conversion=US%RL2_T2_to_Pa*US%Z_to_m*US%T_to_s) !vertically integrated viscosity CS%id_taub = register_diag_field('ice_shelf_model','taub_beta',CS%diag%axesT1, Time, & - 'taub', 'MPa', conversion=1e-6*US%RL2_T2_to_Pa) + 'taub', 'MPa s m-1', conversion=1e-6*US%RL2_T2_to_Pa/(365.0*86400.0*US%L_T_to_m_s)) CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) endif @@ -720,7 +738,8 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity !! [R L2 Z T-1 ~> Pa s m] - real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged basal traction [R L2 T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged taub_beta field related to basal traction, + !! [R L1 T-1 ~> Pa s m-1] integer :: iters logical :: update_ice_vel, coupled_GL @@ -2198,8 +2217,8 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points !! relative to sea-level [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional @@ -2373,8 +2392,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are @@ -2533,8 +2552,8 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, !! flow law. The exact form and units depend on the !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice @@ -2814,6 +2833,10 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] + real :: alpha !Coulomb coefficient [nondim] + real :: Hf !"floatation thickness" for Coulomb friction [Z ~> m] + real :: fN !Effective pressure (ice pressure - ocean pressure) for Coulomb friction [R L2 T-2 ~> Pa] + real :: fB !for Coulomb Friction [(L T-1)^CS%CF_PostPeak ~> (m s-1)^CS%CF_PostPeak] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -2825,15 +2848,34 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) eps_min = CS%eps_glen_min + if (CS%CoulombFriction) then + if (CS%CF_PostPeak.ne.1.0) THEN + alpha = (CS%CF_PostPeak-1.0)**(CS%CF_PostPeak-1.0) / CS%CF_PostPeak**CS%CF_PostPeak ![nondim] + else + alpha = 1.0 + endif + endif do j=jsd+1,jed do i=isd+1,ied if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 - unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) -! CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) - CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) + unorm = US%L_T_to_m_s*sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) + + !Coulomb friction (Schoof 2005, Gagliardini et al 2007) + if (CS%CoulombFriction) then + !Effective pressure + Hf = max(CS%density_ocean_avg * CS%bed_elev(i,j)/CS%density_ice, 0.0) + fN = max(CS%density_ice * CS%g_Earth * (ISS%h_shelf(i,j) - Hf),CS%CF_MinN) + + fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * & + unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(CS%n_basal_fric) + else + !linear (CS%n_basal_fric=1) or "Weertman"/power-law (CS%n_basal_fric .ne. 1) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * unorm**(CS%n_basal_fric-1) + endif endif enddo enddo From 0c491ce12f74a1823d10b13823088cca1f81c010 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 13 Oct 2023 10:09:06 -0800 Subject: [PATCH 117/146] +REMAP_AUX needs at least one more halo update. (#496) * +REMAP_AUX needs at least one more halo update. - This one is for CS%u_av, CS%v_av, which need to be updated coming into step_MOM_dyn_split_RK2. * +Next stab at fixing REMAP_AUX fallout. - This fixes the Bering ORLANSKI OBCs for differing processor counts. - This is either the wrong way to do group_pass for OBLIQUE OBC's or there is more wrong with them. * Adding a group pass, still not solving the problem - Problem is in tangential_vel at tile boundaries. It matches right at the boundary, but needs some halo points to match too. * +Fixing oblique OBCs - Without this, u_av and v_av don't update a wide enough halo to get answers to reproduce across different processor counts with oblique OBCs. * Fixed an oopsie with OBC * Getting rid of extra exchange (that didn't help) --- src/core/MOM_dynamics_split_RK2.F90 | 16 +++++++++++----- src/core/MOM_open_boundary.F90 | 20 +++++++++++++++++--- 2 files changed, 28 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index feb0b7e582..c506d12139 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -388,7 +388,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s logical :: showCallTree, sym integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: cont_stencil + integer :: cont_stencil, obc_stencil is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -451,19 +451,23 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !--- begin set up for group halo pass cont_stencil = continuity_stencil(CS%continuity_CSp) + obc_stencil = 2 + if (associated(CS%OBC)) then + if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 + endif call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=2) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) call create_group_pass(CS%pass_uv, u, v, G%Domain, halo=max(2,cont_stencil)) call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=2) - call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=2) + call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass @@ -1203,7 +1207,9 @@ subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old, h_new, ALE_CSp, OBC, d if (CS%store_CAu) then call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%u_av, CS%v_av, OBC, dzRegrid) + call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%CAu_pred, CS%CAv_pred, OBC, dzRegrid) + call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.true.) endif call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%diffu, CS%diffv, OBC, dzRegrid) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c995adb671..13ce524006 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -9,6 +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 : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_All, EAST_FACE, NORTH_FACE, SCALAR_PAIR, CGRID_NE, CORNER use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type, log_param @@ -373,6 +374,7 @@ module MOM_open_boundary !! for remapping. Values below 20190101 recover the remapping !! answers from 2018, while higher values use more robust !! forms of the same remapping expressions. + type(group_pass_type) :: pass_oblique !< Structure for group halo pass end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -1886,9 +1888,13 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) 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) then - call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) - call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) - call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call do_group_pass(OBC%pass_oblique, G%Domain) endif if (allocated(OBC%tres_x) .and. allocated(OBC%tres_y)) then do m=1,OBC%ntr @@ -5628,6 +5634,14 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) enddo endif enddo ; endif ; endif + 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) then + call do_group_pass(OBC%pass_oblique, G%Domain) +! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + endif end subroutine remap_OBC_fields From ead68d4984de1e64f30388a692a3fe60ce851744 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 12 Jun 2023 06:35:01 -0400 Subject: [PATCH 118/146] +Refactored diapyc_energy_req_test Refactored diapyc_energy_req_test and diapyc_energy_req_calc to remove the dependence on the Boussinesq reference density when in non-Boussinesq mode. This includes changes to the scaled units of the Kd_int argument to diapyc_energy_req_calc and the Kd argument to diapyc_energy_req_calc and the addition of a new argument to diapyc_energy_req_calc. A call to thickness_to_dz is used for the thickness unit conversions. There are 5 new internal variables, and changes to the units of several others. These routines are not actively used in MOM6 solutions, but instead they are used for testing and debugging new code, so there are no changes to solutions, but the results of these routines can differ in fully non-Boussinesq mode. --- .../vertical/MOM_diapyc_energy_req.F90 | 120 +++++++++++------- 1 file changed, 77 insertions(+), 43 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index bbc4c9bf96..32b0423cd9 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -6,13 +6,14 @@ module MOM_diapyc_energy_req !! \author By Robert Hallberg, May 2015 use MOM_diag_mediator, only : diag_ctrl, Time_type, post_data, register_diag_field +use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -59,20 +60,25 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. type(diapyc_energy_req_CS), pointer :: CS !< This module's control structure. real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke+1), & - optional, intent(in) :: Kd_int !< Interface diffusivities [Z2 T-1 ~> m2 s-1]. + optional, intent(in) :: Kd_int !< Interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables real, dimension(GV%ke) :: & T0, S0, & ! T0 & S0 are columns of initial temperatures and salinities [C ~> degC] and [S ~> ppt]. - h_col ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. + h_col, & ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. + dz_col ! dz_col is a column of vertical distances across layers at tracer points [Z ~> m] + real, dimension( G%isd:G%ied,GV%ke) :: & + dz_2d ! A 2-d slice of the vertical distance across layers [Z ~> m] real, dimension(GV%ke+1) :: & - Kd, & ! A column of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1]. + Kd, & ! A column of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. h_top, h_bot ! Distances from the top or bottom [H ~> m or kg m-2]. + real :: dz_h_int ! The ratio of the vertical distances across the layers surrounding an interface + ! over the layer thicknesses [H Z-1 ~> nonodim or kg m-3] real :: ustar ! The local friction velocity [Z T-1 ~> m s-1] real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] real :: htot ! The sum of the thicknesses [H ~> m or kg m-2]. real :: energy_Kd ! The energy used by diapycnal mixing [R Z L2 T-3 ~> W m-2]. - real :: tmp1 ! A temporary array [H Z ~> m2 or kg m-1] + real :: tmp1 ! A temporary array [H2 ~> m2 or kg2 m-6] integer :: i, j, k, is, ie, js, je, nz logical :: may_print is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -84,36 +90,56 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) "Module must be initialized before it is used.") !$OMP do - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then - if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then - do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo - else - htot = 0.0 ; h_top(1) = 0.0 + do j=js,je + call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) + + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + do k=1,nz T0(k) = tv%T(i,j,k) ; S0(k) = tv%S(i,j,k) h_col(k) = h_3d(i,j,k) - h_top(K+1) = h_top(K) + h_col(k) - enddo - htot = h_top(nz+1) - h_bot(nz+1) = 0.0 - do k=nz,1,-1 - h_bot(K) = h_bot(K+1) + h_col(k) + dz_col(k) = dz_2d(i,k) enddo - ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? - absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) - Kd(1) = 0.0 ; Kd(nz+1) = 0.0 - do K=2,nz - tmp1 = h_top(K) * h_bot(K) * GV%H_to_Z - Kd(K) = CS%test_Kh_scaling * & - ustar * CS%VonKar * (tmp1*ustar) / (absf*tmp1 + htot*ustar) - enddo - endif - may_print = is_root_PE() .and. (i==ie) .and. (j==je) - call diapyc_energy_req_calc(h_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & - may_print=may_print, CS=CS) - endif ; enddo ; enddo + if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then + do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo + else + htot = 0.0 ; h_top(1) = 0.0 + do k=1,nz + h_top(K+1) = h_top(K) + h_col(k) + enddo + htot = h_top(nz+1) + + h_bot(nz+1) = 0.0 + do k=nz,1,-1 + h_bot(K) = h_bot(K+1) + h_col(k) + enddo + + ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? + absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) + Kd(1) = 0.0 ; Kd(nz+1) = 0.0 + if (GV%Boussinesq) then + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (absf*GV%H_to_Z*tmp1 + htot*ustar) + enddo + else + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + dz_h_int = (dz_2d(j,k-1) + dz_2d(j,k) + GV%dz_subroundoff) / & + (h_3d(i,j,k-1) + h_3d(i,j,k) + GV%H_subroundoff) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (dz_h_int*absf*tmp1 + htot*ustar) + enddo + endif + endif + may_print = is_root_PE() .and. (i==ie) .and. (j==je) + call diapyc_energy_req_calc(h_col, dz_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & + may_print=may_print, CS=CS) + endif ; enddo + enddo end subroutine diapyc_energy_req_test @@ -123,17 +149,19 @@ end subroutine diapyc_energy_req_test !! 4 different ways, all of which should be equivalent, but reports only one. !! The various estimates are taken because they will later be used as templates !! for other bits of code -subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & +subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv, & G, GV, US, may_print, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(GV%ke), intent(in) :: h_in !< Layer thickness before entrainment, - !! [H ~> m or kg m-2]. + !! [H ~> m or kg m-2] + real, dimension(GV%ke), intent(in) :: dz_in !< Vertical distance across layers before + !! entrainment [Z ~> m] real, dimension(GV%ke), intent(in) :: T_in !< The layer temperatures [C ~> degC]. real, dimension(GV%ke), intent(in) :: S_in !< The layer salinities [S ~> ppt]. real, dimension(GV%ke+1), intent(in) :: Kd !< The interfaces diapycnal diffusivities - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. real, intent(out) :: energy_Kd !< The column-integrated rate of energy !! consumption by diapycnal diffusion [R Z L2 T-3 ~> W m-2]. @@ -210,8 +238,10 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! in the denominator of b1 in an upward-oriented tridiagonal solver. c1_a, & ! c1_a is used by a downward-oriented tridiagonal solver [nondim]. c1_b, & ! c1_b is used by an upward-oriented tridiagonal solver [nondim]. - h_tr ! h_tr is h at tracer points with a h_neglect added to + h_tr, & ! h_tr is h at tracer points with a h_neglect added to ! ensure positive definiteness [H ~> m or kg m-2]. + dz_tr ! dz_tr is dz at tracer points with dz_neglect added to + ! ensure positive definiteness [Z ~> m] real, dimension(GV%ke+1) :: & pres, & ! Interface pressures [R L2 T-2 ~> Pa]. pres_Z, & ! The hydrostatic interface pressure, which is used to relate @@ -251,6 +281,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: ColHt_cor ! The correction to PE_chg that is made due to a net ! change in the column height [R L2 Z T-2 ~> J m-2]. real :: htot ! A running sum of thicknesses [H ~> m or kg m-2]. + real :: dztot ! A running sum of vertical distances across layers [Z ~> m] real :: dTe_t2 ! Temporary arrays with integrated temperature changes [C H ~> degC m or degC kg m-2] real :: dSe_t2 ! Temporary arrays with integrated salinity changes [S H ~> ppt m or ppt kg m-2] real :: dT_km1_t2, dT_k_t2 ! Temporary arrays describing temperature changes [C ~> degC]. @@ -298,11 +329,13 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dPEb_dKd(:) = 0.0 ; dPEb_dKd_est(:) = 0.0 ; dPEb_dKd_err(:) = 0.0 dPEb_dKd_err_norm(:) = 0.0 ; dPEb_dKd_trunc(:) = 0.0 - htot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 + htot = 0.0 ; dztot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 do k=1,nz T0(k) = T_in(k) ; S0(k) = S_in(k) h_tr(k) = h_in(k) + dz_tr(k) = dz_in(k) htot = htot + h_tr(k) + dztot = dztot + dz_tr(k) pres(K+1) = pres(K) + (GV%g_Earth * GV%H_to_RZ) * h_tr(k) pres_Z(K+1) = pres(K+1) p_lay(k) = 0.5*(pres(K) + pres(K+1)) @@ -310,13 +343,14 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & enddo do k=1,nz h_tr(k) = max(h_tr(k), 1e-15*htot) + dz_tr(k) = max(dz_tr(k), 1e-15*dztot) enddo ! Introduce a diffusive flux variable, Kddt_h(K) = ea(k) = eb(k-1) Kddt_h(1) = 0.0 ; Kddt_h(nz+1) = 0.0 do K=2,nz - Kddt_h(K) = min((GV%Z_to_H**2*dt)*Kd(k) / (0.5*(h_tr(k-1) + h_tr(k))), 1e3*htot) + Kddt_h(K) = min(dt * Kd(k) / (0.5*(dz_tr(k-1) + dz_tr(k))), 1e3*dztot) enddo ! Solve the tridiagonal equations for new temperatures. @@ -962,7 +996,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz call calculate_density(0.5*(T0(k-1) + T0(k)), 0.5*(S0(k-1) + S0(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (T0(k-1) - T0(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (S0(k-1) - S0(k)) ) enddo @@ -973,7 +1007,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz call calculate_density(0.5*(Tf(k-1) + Tf(k)), 0.5*(Sf(k-1) + Sf(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (Tf(k-1) - Tf(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (Sf(k-1) - Sf(k)) ) enddo From 43a4fa9d48194abd6d56af43db67186d9db59389 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 7 Oct 2023 08:36:03 -0400 Subject: [PATCH 119/146] Refactor diapyc_energy_req_calc and find_PE_chg Modified the MOM_diapyc_energy_req.F90 version of find_PE_chg to align more closely with the version in MOM_energetic_PBL.F90, including making PE_chg into a mandatory argument, changing the name of the ColHt_cor argument to PE_ColHt_cor, and modifying some variable descriptions in units. Also removed find_PE_chg_orig from MOM_diapyc_energy_req.F90 and the old_PE_calc code that calls it. Extra values were also added to Te, Te_a and Te_b and the equivalent salinity variables so that the logical branches at (K==2) and (K=nz) could be simplied out of diapyc_energy_req_calc. Because old_PE_calc had been hard-coded to .false., all answers are bitwise identical. --- .../vertical/MOM_diapyc_energy_req.F90 | 548 ++++-------------- 1 file changed, 121 insertions(+), 427 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 32b0423cd9..7ca432fea4 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -185,11 +185,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dSV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. dSV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. T0, S0, & ! Initial temperatures and salinities [C ~> degC] and [S ~> ppt]. - Te, Se, & ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] - Te_a, Se_a, & ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] - Te_b, Se_b, & ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] Tf, Sf, & ! New final values of the temperatures and salinities [C ~> degC] and [S ~> ppt]. - dTe, dSe, & ! Running (1-way) estimates of temperature and salinity change [C ~> degC] and [S ~> ppt]. Th_a, & ! An effective temperature times a thickness in the layer above, including implicit ! mixing effects with other yet higher layers [C H ~> degC m or degC kg m-2]. Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit @@ -242,6 +238,14 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! ensure positive definiteness [H ~> m or kg m-2]. dz_tr ! dz_tr is dz at tracer points with dz_neglect added to ! ensure positive definiteness [Z ~> m] + ! Note that the following arrays have extra (ficticious) layers above or below the + ! water column for code convenience + real, dimension(0:GV%ke+1) :: & + Te, Se ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(0:GV%ke) :: & + Te_a, Se_a ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(GV%ke+1) :: & + Te_b, Se_b ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] real, dimension(GV%ke+1) :: & pres, & ! Interface pressures [R L2 T-2 ~> Pa]. pres_Z, & ! The hydrostatic interface pressure, which is used to relate @@ -268,10 +272,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv real :: dKd ! The change in the value of Kddt_h [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: dTe_term ! A diffusivity-independent term related to the temperature - ! change in the layer below the interface [C H ~> degC m or degC kg m-2]. - real :: dSe_term ! A diffusivity-independent term related to the salinity - ! change in the layer below the interface [S H ~> ppt m or ppt kg m-2]. real :: Kddt_h_guess ! A guess of the final value of Kddt_h [H ~> m or kg m-2]. real :: dMass ! The mass per unit area within a layer [R Z ~> kg m-2]. real :: dPres ! The hydrostatic pressure change across a layer [R L2 T-2 ~> Pa]. @@ -282,10 +282,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! change in the column height [R L2 Z T-2 ~> J m-2]. real :: htot ! A running sum of thicknesses [H ~> m or kg m-2]. real :: dztot ! A running sum of vertical distances across layers [Z ~> m] - real :: dTe_t2 ! Temporary arrays with integrated temperature changes [C H ~> degC m or degC kg m-2] - real :: dSe_t2 ! Temporary arrays with integrated salinity changes [S H ~> ppt m or ppt kg m-2] - real :: dT_km1_t2, dT_k_t2 ! Temporary arrays describing temperature changes [C ~> degC]. - real :: dS_km1_t2, dS_k_t2 ! Temporary arrays describing salinity changes [S ~> ppt]. logical :: do_print ! The following are a bunch of diagnostic arrays for debugging purposes. @@ -313,7 +309,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv integer :: k, nz, itt, k_cent logical :: surface_BL, bottom_BL, central, halves, debug - logical :: old_PE_calc nz = GV%ke h_neglect = GV%H_subroundoff @@ -353,6 +348,13 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv Kddt_h(K) = min(dt * Kd(k) / (0.5*(dz_tr(k-1) + dz_tr(k))), 1e3*dztot) enddo + ! Zero out the temperature and salinity estimates in the extra (ficticious) layers. + ! The actual values set here are irrelevant (so long as they are not NaNs) because they + ! are always multiplied by a zero value of Kddt_h reflecting the no-flux boundary condition. + Te(0) = 0.0 ; Se(0) = 0.0 ; Te(nz+1) = 0.0 ; Se(nz+1) = 0.0 + Te_a(0) = 0.0 ; Se_a(0) = 0.0 + Te_b(nz+1) = 0.0 ; Se_b(nz+1) = 0.0 + ! Solve the tridiagonal equations for new temperatures. call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, tv%eqn_of_state) @@ -371,7 +373,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv PE_chg_k(:,:) = 0.0 ; ColHt_cor_k(:,:) = 0.0 if (surface_BL) then ! This version is appropriate for a surface boundary layer. - old_PE_calc = .false. ! Set up values appropriate for no diffusivity. do k=1,nz @@ -387,71 +388,32 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! on how much energy is available. ! Precalculate some temporary expressions that are independent of Kddt_h_guess. - if (old_PE_calc) then - if (K==2) then - dT_km1_t2 = (T0(k)-T0(k-1)) - dS_km1_t2 = (S0(k)-S0(k-1)) - dTe_t2 = 0.0 ; dSe_t2 = 0.0 - else - dTe_t2 = Kddt_h(K-1) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - dT_km1_t2 = (T0(k)-T0(k-1)) - & - (Kddt_h(K-1) / hp_a(k-1)) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dS_km1_t2 = (S0(k)-S0(k-1)) - & - (Kddt_h(K-1) / hp_a(k-1)) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - endif - dTe_term = dTe_t2 + hp_a(k-1) * (T0(k-1)-T0(k)) - dSe_term = dSe_t2 + hp_a(k-1) * (S0(k-1)-S0(k)) - else - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) - endif - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - endif + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) ! Find the energy change due to a guess at the strength of diffusion at interface K. Kddt_h_guess = Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & - dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & - dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg_k(k,1), dPEa_dKd(k)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & - ColHt_cor=ColHt_cor_k(K,1)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,1)) if (debug) then do itt=1,5 Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & - dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & - dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg=PE_chg(itt)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg(itt)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg(itt)) enddo ! Compare with a 4th-order finite difference estimate. dPEa_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & @@ -468,17 +430,8 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_a(k-1) + Kddt_h(K)) c1_a(K) = Kddt_h(K) * b1 - if (k==2) then - Te(1) = b1*(h_tr(1)*T0(1)) - Se(1) = b1*(h_tr(1)*S0(1)) - else - Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) - Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) - endif - if (old_PE_calc) then - dTe(k-1) = b1 * ( Kddt_h(K)*(T0(k)-T0(k-1)) + dTe_t2 ) - dSe(k-1) = b1 * ( Kddt_h(K)*(S0(k)-S0(k-1)) + dSe_t2 ) - endif + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -491,10 +444,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_a(nz)) Tf(nz) = b1 * (h_tr(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) Sf(nz) = b1 * (h_tr(nz) * S0(nz) + Kddt_h(nz) * Se(nz-1)) - if (old_PE_calc) then - dTe(nz) = b1 * Kddt_h(nz) * ((T0(nz-1)-T0(nz)) + dTe(nz-1)) - dSe(nz) = b1 * Kddt_h(nz) * ((S0(nz-1)-S0(nz)) + dSe(nz-1)) - endif do k=nz-1,1,-1 Tf(k) = Te(k) + c1_a(K+1)*Tf(k+1) @@ -517,7 +466,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv endif if (bottom_BL) then ! This version is appropriate for a bottom boundary layer. - old_PE_calc = .false. ! Set up values appropriate for no diffusivity. do k=1,nz @@ -533,71 +481,32 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! on how much energy is available. ! Precalculate some temporary expressions that are independent of Kddt_h_guess. - if (old_PE_calc) then - if (K==nz) then - dT_k_t2 = (T0(k-1)-T0(k)) - dS_k_t2 = (S0(k-1)-S0(k)) - dTe_t2 = 0.0 ; dSe_t2 = 0.0 - else - dTe_t2 = Kddt_h(K+1) * ((T0(k+1) - T0(k)) + dTe(k+1)) - dSe_t2 = Kddt_h(K+1) * ((S0(k+1) - S0(k)) + dSe(k+1)) - dT_k_t2 = (T0(k-1)-T0(k)) - & - (Kddt_h(k+1)/ hp_b(k)) * ((T0(k+1) - T0(k)) + dTe(k+1)) - dS_k_t2 = (S0(k-1)-S0(k)) - & - (Kddt_h(k+1)/ hp_b(k)) * ((S0(k+1) - S0(k)) + dSe(k+1)) - endif - dTe_term = dTe_t2 + hp_b(k) * (T0(k)-T0(k-1)) - dSe_term = dSe_t2 + hp_b(k) * (S0(k)-S0(k-1)) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se(k+1) - endif - endif + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1) ! Find the energy change due to a guess at the strength of diffusion at interface K. Kddt_h_guess = Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & - dTe_term, dSe_term, dT_k_t2, dS_k_t2, & - dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & - ColHt_cor=ColHt_cor_k(K,2)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,2)) if (debug) then ! Compare with a 4th-order finite difference estimate. do itt=1,5 Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & - dTe_term, dSe_term, dT_k_t2, dS_k_t2, & - dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg(itt)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg(itt)) - endif enddo dPEb_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & @@ -614,17 +523,9 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_b(k) + Kddt_h(K)) c1_b(K) = Kddt_h(K) * b1 - if (k==nz) then - Te(nz) = b1* (h_tr(nz)*T0(nz)) - Se(nz) = b1* (h_tr(nz)*S0(nz)) - else - Te(k) = b1 * (h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) - Se(k) = b1 * (h_tr(k) * S0(k) + Kddt_h(k+1) * Se(k+1)) - endif - if (old_PE_calc) then - dTe(k) = b1 * ( Kddt_h(K)*(T0(k-1)-T0(k)) + dTe_t2 ) - dSe(k) = b1 * ( Kddt_h(K)*(S0(k-1)-S0(k)) + dSe_t2 ) - endif + + Te(k) = b1 * (h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -637,10 +538,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_b(1)) Tf(1) = b1 * (h_tr(1) * T0(1) + Kddt_h(2) * Te(2)) Sf(1) = b1 * (h_tr(1) * S0(1) + Kddt_h(2) * Se(2)) - if (old_PE_calc) then - dTe(1) = b1 * Kddt_h(2) * ((T0(2)-T0(1)) + dTe(2)) - dSe(1) = b1 * Kddt_h(2) * ((S0(2)-S0(1)) + dSe(2)) - endif do k=2,nz Tf(k) = Te(k) + c1_b(K)*Tf(k-1) @@ -678,12 +575,9 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv do K=2,nz ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) Kddt_h_a(K) = 0.0 ; if (K < K_cent) Kddt_h_a(K) = Kddt_h(K) @@ -694,19 +588,15 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_change ColHt_cor_k(K,3) = ColHt_cor b1 = 1.0 / (hp_a(k-1) + Kddt_h_a(K)) c1_a(K) = Kddt_h_a(K) * b1 - if (k==2) then - Te_a(1) = b1*(h_tr(1)*T0(1)) - Se_a(1) = b1*(h_tr(1)*S0(1)) - else - Te_a(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h_a(K-1) * Te_a(k-2)) - Se_a(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h_a(K-1) * Se_a(k-2)) - endif + + Te_a(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h_a(K-1) * Te_a(k-2)) + Se_a(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h_a(K-1) * Se_a(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h_a(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -720,18 +610,13 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv do K=nz,2,-1 ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). -! if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) -! else -! Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) -! Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) -! endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se_b(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) +! Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) +! Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) Kddt_h_b(K) = 0.0 ; if (K > K_cent) Kddt_h_b(K) = Kddt_h(K) dKd = Kddt_h_b(K) @@ -741,19 +626,15 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor b1 = 1.0 / (hp_b(k) + Kddt_h_b(K)) c1_b(K) = Kddt_h_b(K) * b1 - if (k==nz) then - Te_b(k) = b1 * (h_tr(k)*T0(k)) - Se_b(k) = b1 * (h_tr(k)*S0(k)) - else - Te_b(k) = b1 * (h_tr(k) * T0(k) + Kddt_h_b(K+1) * Te_b(k+1)) - Se_b(k) = b1 * (h_tr(k) * S0(k) + Kddt_h_b(k+1) * Se_b(k+1)) - endif + + Te_b(k) = b1 * (h_tr(k) * T0(k) + Kddt_h_b(K+1) * Te_b(k+1)) + Se_b(k) = b1 * (h_tr(k) * S0(k) + Kddt_h_b(K+1) * Se_b(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h_b(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -768,18 +649,11 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) - endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se_b(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) dKd = Kddt_h(K) @@ -788,7 +662,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor @@ -854,16 +728,12 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv enddo ! Calculate the dependencies on layers above. - Kddt_h_a(1) = 0.0 do K=2,nz ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = Kd_so_far(K) - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) dKd = 0.5 * Kddt_h(K) - Kd_so_far(K) @@ -873,7 +743,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,4) = PE_change ColHt_cor_k(K,4) = ColHt_cor @@ -882,13 +752,9 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_a(k-1) + Kd_so_far(K)) c1_a(K) = Kd_so_far(K) * b1 - if (k==2) then - Te(1) = b1*(h_tr(1)*T0(1)) - Se(1) = b1*(h_tr(1)*S0(1)) - else - Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2)) - Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2)) - endif + + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kd_so_far(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -901,18 +767,11 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv do K=nz,2,-1 ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = Kd_so_far(K) - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) - endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1) dKd = Kddt_h(K) - Kd_so_far(K) @@ -921,7 +780,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,4) = PE_chg_k(K,4) + PE_change ColHt_cor_k(K,4) = ColHt_cor_k(K,4) + ColHt_cor @@ -931,13 +790,9 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_b(k) + Kd_so_far(K)) c1_b(K) = Kd_so_far(K) * b1 - if (k==nz) then - Te(k) = b1 * (h_tr(k)*T0(k)) - Se(k) = b1 * (h_tr(k)*S0(k)) - else - Te(k) = b1 * (h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1)) - Se(k) = b1 * (h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1)) - endif + + Te(k) = b1 * (h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kd_so_far(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -1018,11 +873,11 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv end subroutine diapyc_energy_req_calc !> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep. +!! for several changes in an interface's diapycnal diffusivity times a timestep. subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & - PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, ColHt_cor) + PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, PE_ColHt_cor) real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times !! the time step and divided by the average of the !! thicknesses around the interface [H ~> m or kg m-2]. @@ -1050,22 +905,22 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! below, including implicit mixing effects with other !! yet lower layers [S H ~> ppt m or ppt kg m-2]. real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating @@ -1085,8 +940,8 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! height, including all implicit diffusive changes !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. - real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. + real, intent(out) :: PE_chg !< The change in column potential energy from applying + !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could @@ -1094,17 +949,18 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - real, optional, intent(out) :: ColHt_cor !< The correction to PE_chg that is made due to a net + real, optional, intent(out) :: PE_ColHt_cor !< The correction to PE_chg that is made due to a net !! change in the column height [R Z L2 T-2 ~> J m-2]. + ! Local variables real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. real :: dT_c ! The core term in the expressions for the temperature changes [C H2 ~> degC m2 or degC kg2 m-4]. - real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> psu m2 or psu kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> ppt m2 or ppt kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions - ! for the potential energy changes [R L2 T-2 ~> J m-3]. + ! for the potential energy changes [H3 R Z L2 T-2 ~> J m or J kg3 m-8]. real :: ColHt_core ! The diffusivity-independent core term in the expressions - ! for the column height changes [R L2 T-2 ~> J m-3]. + ! for the column height changes [H3 Z ~> m4 or kg3 m-5]. real :: ColHt_chg ! The change in the column height [Z ~> m]. real :: y1_3 ! A local temporary term in [H-3 ~> m-3 or m6 kg-3]. real :: y1_4 ! A local temporary term in [H-4 ~> m-4 or m8 kg-4]. @@ -1112,7 +968,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ! The expression for the change in potential energy used here is derived ! from the expression for the final estimates of the changes in temperature ! and salinities, and then extensively manipulated to get it into its most - ! succint form. The derivation is not necessarily obvious, but it demonstrably + ! succinct form. The derivation is not necessarily obvious, but it demonstrably ! works by comparison with separate calculations of the energy changes after ! the tridiagonal solver for the final changes in temperature and salinity are ! applied. @@ -1126,18 +982,14 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ColHt_core = hp_b * (dT_to_dColHt_a * dT_c + dS_to_dColHt_a * dS_c) - & hp_a * (dT_to_dColHt_b * dT_c + dS_to_dColHt_b * dS_c) - if (present(PE_chg)) then - ! Find the change in column potential energy due to the change in the - ! diffusivity at this interface by dKddt_h. - y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - PE_chg = PEc_core * y1_3 - ColHt_chg = ColHt_core * y1_3 - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg - if (present(ColHt_cor)) ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) - elseif (present(ColHt_cor)) then - y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - ColHt_cor = -pres_Z * min(ColHt_core * y1_3, 0.0) - endif + ! Find the change in column potential energy due to the change in the + ! diffusivity at this interface by dKddt_h. + y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) + PE_chg = PEc_core * y1_3 + ColHt_chg = ColHt_core * y1_3 + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg + + if (present(PE_ColHt_cor)) PE_ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) if (present(dPEc_dKd)) then ! Find the derivative of the potential energy change with dKddt_h. @@ -1166,164 +1018,6 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & end subroutine find_PE_chg -!> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep -!! using the original form used in the first version of ePBL. -subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & - dT_km1_t2, dS_km1_t2, dT_to_dPE_k, dS_to_dPE_k, & - dT_to_dPEa, dS_to_dPEa, pres_Z, dT_to_dColHt_k, & - dS_to_dColHt_k, dT_to_dColHta, dS_to_dColHta, & - PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0) - real, intent(in) :: Kddt_h !< The diffusivity at an interface times the time step and - !! divided by the average of the thicknesses around the - !! interface [H ~> m or kg m-2]. - real, intent(in) :: h_k !< The thickness of the layer below the interface [H ~> m or kg m-2]. - real, intent(in) :: b_den_1 !< The first term in the denominator of the pivot - !! for the tridiagonal solver, given by h_k plus a term that - !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above [H ~> m or kg m-2]. - real, intent(in) :: dTe_term !< A diffusivity-independent term related to the temperature change - !! in the layer below the interface [C H ~> degC m or degC kg m-2]. - real, intent(in) :: dSe_term !< A diffusivity-independent term related to the salinity change - !! in the layer below the interface [S H ~> ppt m or ppt kg m-2]. - real, intent(in) :: dT_km1_t2 !< A diffusivity-independent term related to the - !! temperature change in the layer above the interface [C ~> degC]. - real, intent(in) :: dS_km1_t2 !< A diffusivity-independent term related to the - !! salinity change in the layer above the interface [S ~> ppt]. - real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate - !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. - real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. - real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. - real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating - !! a layer's temperature change to the change in column - !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below [Z C-1 ~> m degC-1]. - real, intent(in) :: dS_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dS) relating - !! a layer's salinity change to the change in column - !! height, including all implicit diffusive changes - !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. - real, intent(in) :: dT_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dT) relating - !! a layer's temperature change to the change in column - !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. - real, intent(in) :: dS_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dS) relating - !! a layer's salinity change to the change in column - !! height, including all implicit diffusive changes - !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. - - real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realized by applying a huge value of Kddt_h at the - !! present interface [R Z L2 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - -! This subroutine determines the total potential energy change due to mixing -! at an interface, including all of the implicit effects of the prescribed -! mixing at interfaces above. Everything here is derived by careful manipulation -! of the robust tridiagonal solvers used for tracers by MOM6. The results are -! positive for mixing in a stably stratified environment. -! The comments describing these arguments are for a downward mixing pass, but -! this routine can also be used for an upward pass with the sense of direction -! reversed. - - real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: b1Kd ! Temporary array [nondim] - real :: ColHt_chg ! The change in column thickness [Z ~> m]. - real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. - real :: dColHt_dKd ! The partial derivative of column thickness with Kddt_h [Z H-1 ~> nondim or m3 kg-1] - real :: dT_k, dT_km1 ! Temperature changes in layers k and k-1 [C ~> degC] - real :: dS_k, dS_km1 ! Salinity changes in layers k and k-1 [S ~> ppt] - real :: I_Kr_denom ! Temporary array [H-2 ~> m-2 or m4 kg-2] - real :: dKr_dKd ! Temporary array [H-2 ~> m-2 or m4 kg-2] - real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays indicating the temperature changes - ! per unit change in Kddt_h [C H-1 ~> degC m-1 or degC m2 kg-1] - real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays indicating the salinity changes - ! per unit change in Kddt_h [S H-1 ~> ppt m-1 or ppt m2 kg-1] - - b1 = 1.0 / (b_den_1 + Kddt_h) - b1Kd = Kddt_h*b1 - - ! Start with the temperature change in layer k-1 due to the diffusivity at - ! interface K without considering the effects of changes in layer k. - - ! Calculate the change in PE due to the diffusion at interface K - ! if Kddt_h(K+1) = 0. - I_Kr_denom = 1.0 / (h_k*b_den_1 + (b_den_1 + h_k)*Kddt_h) - - dT_k = (Kddt_h*I_Kr_denom) * dTe_term - dS_k = (Kddt_h*I_Kr_denom) * dSe_term - - if (present(PE_chg)) then - ! Find the change in energy due to diffusion with strength Kddt_h at this interface. - ! Increment the temperature changes in layer k-1 due the changes in layer k. - dT_km1 = b1Kd * ( dT_k + dT_km1_t2 ) - dS_km1 = b1Kd * ( dS_k + dS_km1_t2 ) - - PE_chg = (dT_to_dPE_k * dT_k + dT_to_dPEa * dT_km1) + & - (dS_to_dPE_k * dS_k + dS_to_dPEa * dS_km1) - ColHt_chg = (dT_to_dColHt_k * dT_k + dT_to_dColHta * dT_km1) + & - (dS_to_dColHt_k * dS_k + dS_to_dColHta * dS_km1) - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg - endif - - if (present(dPEc_dKd)) then - ! Find the derivatives of the temperature and salinity changes with Kddt_h. - dKr_dKd = (h_k*b_den_1) * I_Kr_denom**2 - - ddT_k_dKd = dKr_dKd * dTe_term - ddS_k_dKd = dKr_dKd * dSe_term - ddT_km1_dKd = (b1**2 * b_den_1) * ( dT_k + dT_km1_t2 ) + b1Kd * ddT_k_dKd - ddS_km1_dKd = (b1**2 * b_den_1) * ( dS_k + dS_km1_t2 ) + b1Kd * ddS_k_dKd - - ! Calculate the partial derivative of Pe_chg with Kddt_h. - dPEc_dKd = (dT_to_dPE_k * ddT_k_dKd + dT_to_dPEa * ddT_km1_dKd) + & - (dS_to_dPE_k * ddS_k_dKd + dS_to_dPEa * ddS_km1_dKd) - dColHt_dKd = (dT_to_dColHt_k * ddT_k_dKd + dT_to_dColHta * ddT_km1_dKd) + & - (dS_to_dColHt_k * ddS_k_dKd + dS_to_dColHta * ddS_km1_dKd) - if (dColHt_dKd < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * dColHt_dKd - endif - - if (present(dPE_max)) then - ! This expression is the limit of PE_chg for infinite Kddt_h. - dPE_max = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) + & - ((dT_to_dPE_k + dT_to_dPEa) * dTe_term + & - (dS_to_dPE_k + dS_to_dPEa) * dSe_term) / (b_den_1 + h_k) - dColHt_max = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) + & - ((dT_to_dColHt_k + dT_to_dColHta) * dTe_term + & - (dS_to_dColHt_k + dS_to_dColHta) * dSe_term) / (b_den_1 + h_k) - if (dColHt_max < 0.0) dPE_max = dPE_max - pres_Z*dColHt_max - endif - - if (present(dPEc_dKd_0)) then - ! This expression is the limit of dPEc_dKd for Kddt_h = 0. - dPEc_dKd_0 = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) / (b_den_1) + & - (dT_to_dPE_k * dTe_term + dS_to_dPE_k * dSe_term) / (h_k*b_den_1) - dColHt_dKd = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) / (b_den_1) + & - (dT_to_dColHt_k * dTe_term + dS_to_dColHt_k * dSe_term) / (h_k*b_den_1) - if (dColHt_dKd < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z*dColHt_dKd - endif - -end subroutine find_PE_chg_orig - !> Initialize parameters and allocate memory associated with the diapycnal energy requirement module. subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< model time From 475590dbc4d736fd45a29748577351f2eb58fc57 Mon Sep 17 00:00:00 2001 From: Pavel Perezhogin <35234405+Pperezhogin@users.noreply.github.com> Date: Thu, 19 Oct 2023 16:30:23 -0400 Subject: [PATCH 120/146] Acceleration of Zanna-Bolton-2020 parameterization and new features required for NW2 (#484) * Update of Zanna-Bolton-2020 closure: code optimization and features required in NW2 configuration * Resolving compilation errors and doxygen by Alistair * Remove force sync for clock * Change naming of functions according to MOM_Zanna_bolton module --- .../lateral/MOM_Zanna_Bolton.F90 | 1509 +++++++++-------- .../lateral/MOM_hor_visc.F90 | 47 +- 2 files changed, 837 insertions(+), 719 deletions(-) diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index 500e4a508c..b49d123377 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -1,23 +1,26 @@ -! > Calculates Zanna and Bolton 2020 parameterization +!> Calculates Zanna and Bolton 2020 parameterization +!! Implemented by Perezhogin P.A. Contact: pperezhogin@gmail.com module MOM_Zanna_Bolton +! This file is part of MOM6. See LICENSE.md for the license. use MOM_grid, only : ocean_grid_type use MOM_verticalGrid, only : verticalGrid_type use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_unit_scaling, only : unit_scale_type use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type, & + start_group_pass, complete_group_pass use MOM_domains, only : To_North, To_East use MOM_domains, only : pass_var, CORNER -use MOM_coms, only : reproducing_sum, max_across_PEs, min_across_PEs -use MOM_error_handler, only : MOM_error, WARNING +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE implicit none ; private #include -public Zanna_Bolton_2020, ZB_2020_init +public ZB2020_lateral_stress, ZB2020_init, ZB2020_end, ZB2020_copy_gradient_and_thickness !> Control structure for Zanna-Bolton-2020 parameterization. type, public :: ZB2020_CS ; private @@ -31,50 +34,86 @@ module MOM_Zanna_Bolton integer :: ZB_cons !< Select a discretization scheme for ZB model !! 0 - non-conservative scheme !! 1 - conservative scheme for deviatoric component - integer :: LPF_iter !< Number of smoothing passes for the Velocity Gradient (VG) components - !! in ZB model. - integer :: LPF_order !< The scale selectivity of the smoothing filter - !! 1 - Laplacian filter - !! 2 - Bilaplacian filter integer :: HPF_iter !< Number of sharpening passes for the Velocity Gradient (VG) components !! in ZB model. - integer :: HPF_order !< The scale selectivity of the sharpening filter - !! 1 - Laplacian filter - !! 2 - Bilaplacian filter integer :: Stress_iter !< Number of smoothing passes for the Stress tensor components !! in ZB model. - integer :: Stress_order !< The scale selectivity of the smoothing filter - !! 1 - Laplacian filter - !! 2 - Bilaplacian filter - integer :: ssd_iter !< Hyperviscosity parameter. Defines the number of sharpening passes - !! in Laplacian viscosity model: - !! -1: hyperviscosity is off - !! 0: Laplacian viscosity - !! 9: (Laplacian)^10 viscosity, ... - real :: ssd_bound_coef !< The non-dimensional damping coefficient of the grid harmonic - !! by hyperviscous dissipation: - !! 0.0: no damping - !! 1.0: grid harmonic is removed after a step in time - real :: DT !< The (baroclinic) dynamics time step [T ~> s] + real :: Klower_R_diss !< Attenuation of + !! the ZB parameterization in the regions of + !! geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019) + !! Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))) + !! R_diss=-1: attenuation is not used; typical value R_diss=1.0 [nondim] + integer :: Klower_shear !< Type of expression for shear in Klower formula + !! 0: sqrt(sh_xx**2 + sh_xy**2) + !! 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + integer :: Marching_halo !< The number of filter iterations per a single MPI + !! exchange + + real, dimension(:,:,:), allocatable :: & + sh_xx, & !< Horizontal tension (du/dx - dv/dy) in h (CENTER) + !! points including metric terms [T-1 ~> s-1] + sh_xy, & !< Horizontal shearing strain (du/dy + dv/dx) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + vort_xy, & !< Vertical vorticity (dv/dx - du/dy) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + hq !< Thickness in CORNER points [H ~> m or kg m-2] + + real, dimension(:,:,:), allocatable :: & + Txx, & !< Subgrid stress xx component in h [L2 T-2 ~> m2 s-2] + Tyy, & !< Subgrid stress yy component in h [L2 T-2 ~> m2 s-2] + Txy !< Subgrid stress xy component in q [L2 T-2 ~> m2 s-2] + + real, dimension(:,:), allocatable :: & + kappa_h, & !< Scaling coefficient in h points [L2 ~> m2] + kappa_q !< Scaling coefficient in q points [L2 ~> m2] + + real, allocatable :: & + ICoriolis_h(:,:), & !< Inverse Coriolis parameter at h points [T ~> s] + c_diss(:,:,:) !< Attenuation parameter at h points + !! (Klower 2018, Juricke2019,2020) [nondim] + + real, dimension(:,:), allocatable :: & + maskw_h, & !< Mask of land point at h points multiplied by filter weight [nondim] + maskw_q !< Same mask but for q points [nondim] type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1 - integer :: id_maskT = -1 - integer :: id_maskq = -1 - integer :: id_S_11 = -1 - integer :: id_S_22 = -1 - integer :: id_S_12 = -1 + integer :: id_Txx = -1 + integer :: id_Tyy = -1 + integer :: id_Txy = -1 + integer :: id_cdiss = -1 + !>@} + + !>@{ CPU time clock IDs + integer :: id_clock_module + integer :: id_clock_copy + integer :: id_clock_cdiss + integer :: id_clock_stress + integer :: id_clock_divergence + integer :: id_clock_mpi + integer :: id_clock_filter + integer :: id_clock_post + integer :: id_clock_source + !>@} + + !>@{ MPI group passes + type(group_pass_type) :: & + pass_Tq, pass_Th, & !< handles for halo passes of Txy and Txx, Tyy + pass_xx, pass_xy !< handles for halo passes of sh_xx and sh_xy, vort_xy + integer :: Stress_halo = -1, & !< The halo size in filter of the stress tensor + HPF_halo = -1 !< The halo size in filter of the velocity gradient !>@} end type ZB2020_CS contains -!> Read parameters and register output fields -!! used in Zanna_Bolton_2020(). -subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) +!> Read parameters, allocate and precompute arrays, +!! register diagnosicts used in Zanna_Bolton_2020(). +subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020) type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's 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 parser structure. @@ -82,10 +121,19 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. logical, intent(out) :: use_ZB2020 !< If true, turns on ZB scheme. + real :: subroundoff_Cor ! A negligible parameter which avoids division by zero + ! but small compared to Coriolis parameter [T-1 ~> s-1] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_Zanna_Bolton" ! This module's name. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_ZB2020", use_ZB2020, & @@ -95,7 +143,7 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) call get_param(param_file, mdl, "ZB_SCALING", CS%amplitude, & "The nondimensional scaling factor in ZB model, " //& - "typically 0.1 - 10.", units="nondim", default=0.3) + "typically 0.5-2.5", units="nondim", default=0.5) call get_param(param_file, mdl, "ZB_TRACE_MODE", CS%ZB_type, & "Select how to compute the trace part of ZB model:\n" //& @@ -108,59 +156,31 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) "\t 0 - non-conservative scheme\n" //& "\t 1 - conservative scheme for deviatoric component", default=1) - call get_param(param_file, mdl, "VG_SMOOTH_PASS", CS%LPF_iter, & - "Number of smoothing passes for the Velocity Gradient (VG) components " //& - "in ZB model.", default=0) - - call get_param(param_file, mdl, "VG_SMOOTH_SEL", CS%LPF_order, & - "The scale selectivity of the smoothing filter " //& - "for VG components:\n" //& - "\t 1 - Laplacian filter\n" //& - "\t 2 - Bilaplacian filter, ...", & - default=1, do_not_log = CS%LPF_iter==0) - call get_param(param_file, mdl, "VG_SHARP_PASS", CS%HPF_iter, & "Number of sharpening passes for the Velocity Gradient (VG) components " //& "in ZB model.", default=0) - call get_param(param_file, mdl, "VG_SHARP_SEL", CS%HPF_order, & - "The scale selectivity of the sharpening filter " //& - "for VG components:\n" //& - "\t 1 - Laplacian filter\n" //& - "\t 2 - Bilaplacian filter,...", & - default=1, do_not_log = CS%HPF_iter==0) - call get_param(param_file, mdl, "STRESS_SMOOTH_PASS", CS%Stress_iter, & "Number of smoothing passes for the Stress tensor components " //& "in ZB model.", default=0) - call get_param(param_file, mdl, "STRESS_SMOOTH_SEL", CS%Stress_order, & - "The scale selectivity of the smoothing filter " //& - "for the Stress tensor components:\n" //& - "\t 1 - Laplacian filter\n" //& - "\t 2 - Bilaplacian filter,...", & - default=1, do_not_log = CS%Stress_iter==0) - - call get_param(param_file, mdl, "ZB_HYPERVISC", CS%ssd_iter, & - "Select an additional hyperviscosity to stabilize the ZB model:\n" //& - "\t 0 - off\n" //& - "\t 1 - Laplacian viscosity\n" //& - "\t 10 - (Laplacian)**10 viscosity, ...", & - default=0) - ! Convert to the number of sharpening passes - ! applied to the Laplacian viscosity model - CS%ssd_iter = CS%ssd_iter-1 - - call get_param(param_file, mdl, "HYPVISC_GRID_DAMP", CS%ssd_bound_coef, & - "The non-dimensional damping coefficient of the grid harmonic " //& - "by hyperviscous dissipation:\n" //& - "\t 0.0 - no damping\n" //& - "\t 1.0 - grid harmonic is removed after a step in time", & - units="nondim", default=0.2, do_not_log = CS%ssd_iter==-1) - - call get_param(param_file, mdl, "DT", CS%dt, & - "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & - fail_if_missing=.true.) + call get_param(param_file, mdl, "ZB_KLOWER_R_DISS", CS%Klower_R_diss, & + "Attenuation of " //& + "the ZB parameterization in the regions of " //& + "geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019). " //& + "Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))):\n" //& + "\t R_diss=-1. - attenuation is not used\n\t R_diss= 1. - typical value", & + units="nondim", default=-1.) + + call get_param(param_file, mdl, "ZB_KLOWER_SHEAR", CS%Klower_shear, & + "Type of expression for shear in Klower formula:\n" //& + "\t 0: sqrt(sh_xx**2 + sh_xy**2)\n" //& + "\t 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2)", & + default=1, do_not_log=.not.CS%Klower_R_diss>0) + + call get_param(param_file, mdl, "ZB_MARCHING_HALO", CS%Marching_halo, & + "The number of filter iterations per single MPI " //& + "exchange", default=4, do_not_log=(CS%Stress_iter==0).and.(CS%HPF_iter==0)) ! Register fields for output from this module. CS%diag => diag @@ -173,726 +193,832 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) 'Kinetic Energy Source from Horizontal Viscosity', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) - CS%id_maskT = register_diag_field('ocean_model', 'maskT', diag%axesTL, Time, & - 'Mask of wet points in T (CENTER) points', '1', conversion=1.) + CS%id_Txx = register_diag_field('ocean_model', 'Txx', diag%axesTL, Time, & + 'Diagonal term (Txx) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Tyy = register_diag_field('ocean_model', 'Tyy', diag%axesTL, Time, & + 'Diagonal term (Tyy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Txy = register_diag_field('ocean_model', 'Txy', diag%axesBL, Time, & + 'Off-diagonal term (Txy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + if (CS%Klower_R_diss > 0) then + CS%id_cdiss = register_diag_field('ocean_model', 'c_diss', diag%axesTL, Time, & + 'Klower (2018) attenuation coefficient', 'nondim') + endif + + ! Clock IDs + ! Only module is measured with syncronization. While smaller + ! parts are measured without - because these are nested clocks. + CS%id_clock_module = cpu_clock_id('(Ocean Zanna-Bolton-2020)', grain=CLOCK_MODULE) + CS%id_clock_copy = cpu_clock_id('(ZB2020 copy fields)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_cdiss = cpu_clock_id('(ZB2020 compute c_diss)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_stress = cpu_clock_id('(ZB2020 compute stress)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_divergence = cpu_clock_id('(ZB2020 compute divergence)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_mpi = cpu_clock_id('(ZB2020 filter MPI exchanges)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_filter = cpu_clock_id('(ZB2020 filter no MPI)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_post = cpu_clock_id('(ZB2020 post data)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_source = cpu_clock_id('(ZB2020 compute energy source)', grain=CLOCK_ROUTINE, sync=.false.) + + ! Allocate memory + ! We set the stress tensor and velocity gradient tensor to zero + ! with full halo because they potentially may be filtered + ! with marching halo algorithm + allocate(CS%sh_xx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%sh_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%vort_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%hq(SZIB_(G),SZJB_(G),SZK_(GV))) + + allocate(CS%Txx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Tyy(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Txy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%kappa_h(SZI_(G),SZJ_(G))) + allocate(CS%kappa_q(SZIB_(G),SZJB_(G))) + + ! Precomputing the scaling coefficient + ! Mask is included to automatically satisfy B.C. + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%kappa_h(i,j) = -CS%amplitude * G%areaT(i,j) * G%mask2dT(i,j) + enddo; enddo + + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + CS%kappa_q(I,J) = -CS%amplitude * G%areaBu(I,J) * G%mask2dBu(I,J) + enddo; enddo + + if (CS%Klower_R_diss > 0) then + allocate(CS%ICoriolis_h(SZI_(G),SZJ_(G))) + allocate(CS%c_diss(SZI_(G),SZJ_(G),SZK_(GV))) + + subroundoff_Cor = 1e-30 * US%T_to_s + ! Precomputing 1/(f * R_diss) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%ICoriolis_h(i,j) = 1. / ((abs(0.25 * ((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) & + + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1)))) + subroundoff_Cor) & + * CS%Klower_R_diss) + enddo; enddo + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + ! Include 1/16. factor to the mask for filter implementation + allocate(CS%maskw_h(SZI_(G),SZJ_(G))); CS%maskw_h(:,:) = G%mask2dT(:,:) * 0.0625 + allocate(CS%maskw_q(SZIB_(G),SZJB_(G))); CS%maskw_q(:,:) = G%mask2dBu(:,:) * 0.0625 + endif + + ! Initialize MPI group passes + if (CS%Stress_iter > 0) then + ! reduce size of halo exchange accordingly to + ! Marching halo, number of iterations and the array size + ! But let exchange width be at least 1 + CS%Stress_halo = max(min(CS%Marching_halo, CS%Stress_iter, & + G%Domain%nihalo, G%Domain%njhalo), 1) + + call create_group_pass(CS%pass_Tq, CS%Txy, G%Domain, halo=CS%Stress_halo, & + position=CORNER) + call create_group_pass(CS%pass_Th, CS%Txx, G%Domain, halo=CS%Stress_halo) + call create_group_pass(CS%pass_Th, CS%Tyy, G%Domain, halo=CS%Stress_halo) + endif + + if (CS%HPF_iter > 0) then + ! The minimum halo size is 2 because it is requirement for the + ! outputs of function filter_velocity_gradients + CS%HPF_halo = max(min(CS%Marching_halo, CS%HPF_iter, & + G%Domain%nihalo, G%Domain%njhalo), 2) + + call create_group_pass(CS%pass_xx, CS%sh_xx, G%Domain, halo=CS%HPF_halo) + call create_group_pass(CS%pass_xy, CS%sh_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + call create_group_pass(CS%pass_xy, CS%vort_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + endif + +end subroutine ZB2020_init - CS%id_maskq = register_diag_field('ocean_model', 'maskq', diag%axesBL, Time, & - 'Mask of wet points in q (CORNER) points', '1', conversion=1.) +!> Deallocate any variables allocated in ZB_2020_init +subroutine ZB2020_end(CS) + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. - ! action of filter on momentum flux - CS%id_S_11 = register_diag_field('ocean_model', 'S_11', diag%axesTL, Time, & - 'Diagonal term (11) in the ZB stress tensor', 'm2s-2', conversion=US%L_T_to_m_s**2) + deallocate(CS%sh_xx) + deallocate(CS%sh_xy) + deallocate(CS%vort_xy) + deallocate(CS%hq) - CS%id_S_22 = register_diag_field('ocean_model', 'S_22', diag%axesTL, Time, & - 'Diagonal term (22) in the ZB stress tensor', 'm2s-2', conversion=US%L_T_to_m_s**2) + deallocate(CS%Txx) + deallocate(CS%Tyy) + deallocate(CS%Txy) + deallocate(CS%kappa_h) + deallocate(CS%kappa_q) - CS%id_S_12 = register_diag_field('ocean_model', 'S_12', diag%axesBL, Time, & - 'Off-diagonal term in the ZB stress tensor', 'm2s-2', conversion=US%L_T_to_m_s**2) + if (CS%Klower_R_diss > 0) then + deallocate(CS%ICoriolis_h) + deallocate(CS%c_diss) + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + deallocate(CS%maskw_h) + deallocate(CS%maskw_q) + endif + +end subroutine ZB2020_end + +!> Save precomputed velocity gradients and thickness +!! from the horizontal eddy viscosity module +!! We save as much halo for velocity gradients as possible +!! In symmetric (preferable) memory model: halo 2 for sh_xx +!! and halo 1 for sh_xy and vort_xy +!! We apply zero boundary conditions to velocity gradients +!! which is required for filtering operations +subroutine ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, & + G, GV, CS, k) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: sh_xy !< horizontal shearing strain (du/dy + dv/dx) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: vort_xy !< Vertical vorticity (dv/dx - du/dy) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: hq !< harmonic mean of the harmonic means + !! of the u- & v point thicknesses [H ~> m or kg m-2] + + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: sh_xx !< horizontal tension (du/dx - dv/dy) + !! including metric terms [T-1 ~> s-1] + + integer, intent(in) :: k !< The vertical index of the layer to be passed. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + + call cpu_clock_begin(CS%id_clock_copy) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + do J=js-1,Jeq ; do I=is-1,Ieq + CS%hq(I,J,k) = hq(I,J) + enddo; enddo + + ! No physical B.C. is required for + ! sh_xx in ZB2020. However, filtering + ! may require BC + do j=Jsq-1,je+2 ; do i=Isq-1,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j) * G%mask2dT(i,j) + enddo ; enddo + + ! We multiply by mask to remove + ! implicit dependence on CS%no_slip + ! flag in hor_visc module + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J) * G%mask2dBu(I,J) + enddo; enddo + + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%vort_xy(I,J,k) = vort_xy(I,J) * G%mask2dBu(I,J) + enddo; enddo -end subroutine ZB_2020_init + call cpu_clock_end(CS%id_clock_copy) + +end subroutine ZB2020_copy_gradient_and_thickness !> Baroclinic Zanna-Bolton-2020 parameterization, see !! eq. 6 in https://laurezanna.github.io/files/Zanna-Bolton-2020.pdf -!! We collect all contributions to a tensor S, with components: -!! (S_11, S_12; -!! S_12, S_22) -!! Which consists of the deviatoric and trace components, respectively: -!! S = (-vort_xy * sh_xy, vort_xy * sh_xx; -!! vort_xy * sh_xx, vort_xy * sh_xy) + -!! 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2, 0; -!! 0, vort_xy^2 + sh_xy^2 + sh_xx^2) -!! Where: -!! vort_xy = dv/dx - du/dy - relative vorticity -!! sh_xy = dv/dx + du/dy - shearing deformation (or horizontal shear strain) -!! sh_xx = du/dx - dv/dy - stretching deformation (or horizontal tension) -!! Update of the governing equations: -!! (du/dt, dv/dt) = k_BC * div(S) -!! Where: -!! k_BC = - amplitude * grid_cell_area -!! amplitude = 0.1..10 (approx) - -subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. +!! We compute the lateral stress tensor according to ZB2020 model +!! and update the acceleration due to eddy viscosity (diffu, diffv) +!! as follows: +!! diffu = diffu + ZB2020u +!! diffv = diffv + ZB2020v +subroutine ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS, & + dx2h, dy2h, dx2q, dy2q) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: fx !< Zonal acceleration due to convergence of - !! along-coordinate stress tensor [L T-2 ~> m s-2] + intent(inout) :: diffu !< Zonal acceleration due to eddy viscosity. + !! It is updated with ZB closure [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(out) :: fy !< Meridional acceleration due to convergence - !! of along-coordinate stress tensor [L T-2 ~> m s-2] - - ! Arrays defined in h (CENTER) points - real, dimension(SZI_(G),SZJ_(G)) :: & - dx_dyT, & ! dx/dy at h points [nondim] - dy_dxT, & ! dy/dx at h points [nondim] - dx2h, & ! dx^2 at h points [L2 ~> m2] - dy2h, & ! dy^2 at h points [L2 ~> m2] - dudx, dvdy, & ! Components in the horizontal tension [T-1 ~> s-1] - sh_xx, & ! Horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] - vort_xy_center, & ! Vorticity interpolated to the center [T-1 ~> s-1] - sh_xy_center, & ! Shearing strain interpolated to the center [T-1 ~> s-1] - S_11, S_22, & ! Diagonal terms in the ZB stress tensor: - ! Above Line 539 [L2 T-2 ~> m2 s-2] - ! Below Line 539 it is layer-integrated [H L2 T-2 ~> m3 s-2 or kg s-2] - ssd_11, & ! Diagonal component of hyperviscous stress [L2 T-2 ~> m2 s-2] - ssd_11_coef, & ! Viscosity coefficient in hyperviscous stress in center points - ! [L2 T-1 ~> m2 s-1] - mask_T ! Mask of wet points in T (CENTER) points [nondim] - - ! Arrays defined in q (CORNER) points - real, dimension(SZIB_(G),SZJB_(G)) :: & - dx_dyBu, & ! dx/dy at q points [nondim] - dy_dxBu, & ! dy/dx at q points [nondim] - dx2q, & ! dx^2 at q points [L2 ~> m2] - dy2q, & ! dy^2 at q points [L2 ~> m2] - dvdx, dudy, & ! Components in the shearing strain [T-1 ~> s-1] - vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] - sh_xy, & ! Horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] - sh_xx_corner, & ! Horizontal tension interpolated to the corner [T-1 ~> s-1] - S_12, & ! Off-diagonal term in the ZB stress tensor: - ! Above Line 539 [L2 T-2 ~> m2 s-2] - ! Below Line 539 it is layer-integrated [H L2 T-2 ~> m3 s-2 or kg s-2] - ssd_12, & ! Off-diagonal component of hyperviscous stress [L2 T-2 ~> m2 s-2] - ssd_12_coef, & ! Viscosity coefficient in hyperviscous stress in corner points - ! [L2 T-1 ~> m2 s-1] - mask_q ! Mask of wet points in q (CORNER) points [nondim] - - ! Thickness arrays for computing the horizontal divergence of the stress tensor - real, dimension(SZIB_(G),SZJB_(G)) :: & - hq ! Thickness in CORNER points [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G)) :: & - h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJB_(G)) :: & - h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. - - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - mask_T_3d, & ! Mask of wet points in T (CENTER) points [nondim] - S_11_3d, S_22_3d ! Diagonal terms in the ZB stress tensor [L2 T-2 ~> m2 s-2] + intent(inout) :: diffv !< Meridional acceleration due to eddy viscosity. + !! It is updated with ZB closure [L T-2 ~> m s-2] - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & - mask_q_3d, & ! Mask of wet points in q (CORNER) points [nondim] - S_12_3d ! Off-diagonal term in the ZB stress tensor [L2 T-2 ~> m2 s-2] - - real :: h_neglect ! Thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] - real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] - real :: h2uq, h2vq ! Temporary variables [H2 ~> m2 or kg2 m-4]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] - real :: sum_sq ! 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) [T-2 ~> s-2] - real :: vort_sh ! vort_xy*sh_xy [T-2 ~> s-2] - - real :: k_bc ! Constant in from of the parameterization [L2 ~> m2] - ! Related to the amplitude as follows: - ! k_bc = - amplitude * grid_cell_area < 0 + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n - ! Line 407 of MOM_hor_visc.F90 + call cpu_clock_begin(CS%id_clock_module) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - h_neglect = GV%H_subroundoff ! Line 410 on MOM_hor_visc.F90 - h_neglect3 = h_neglect**3 + ! Compute attenuation if specified + call compute_c_diss(G, GV, CS) - fx(:,:,:) = 0. - fy(:,:,:) = 0. + ! Sharpen velocity gradients if specified + call filter_velocity_gradients(G, GV, CS) - ! Calculate metric terms (line 2119 of MOM_hor_visc.F90) - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J) - DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) - enddo ; enddo + ! Compute the stress tensor given the + ! (optionally sharpened) velocity gradients + call compute_stress(G, GV, CS) - ! Calculate metric terms (line 2122 of MOM_hor_visc.F90) - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j) - DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) - enddo ; enddo + ! Smooth the stress tensor if specified + call filter_stress(G, GV, CS) - if (CS%ssd_iter > -1) then - ssd_11_coef(:,:) = 0. - ssd_12_coef(:,:) = 0. - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - ssd_11_coef(i,j) = ((CS%ssd_bound_coef * 0.25) / CS%DT) & - * ((dx2h(i,j) * dy2h(i,j)) / (dx2h(i,j) + dy2h(i,j))) - enddo; enddo + ! Update the acceleration due to eddy viscosity (diffu, diffv) + ! with the ZB2020 lateral parameterization + call compute_stress_divergence(u, v, h, diffu, diffv, & + dx2h, dy2h, dx2q, dy2q, & + G, GV, CS) - do J=js-1,Jeq ; do I=is-1,Ieq - ssd_12_coef(I,J) = ((CS%ssd_bound_coef * 0.25) / CS%DT) & - * ((dx2q(I,J) * dy2q(I,J)) / (dx2q(I,J) + dy2q(I,J))) - enddo; enddo - endif + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_Txx>0) call post_data(CS%id_Txx, CS%Txx, CS%diag) + if (CS%id_Tyy>0) call post_data(CS%id_Tyy, CS%Tyy, CS%diag) + if (CS%id_Txy>0) call post_data(CS%id_Txy, CS%Txy, CS%diag) - do k=1,nz + if (CS%id_cdiss>0) call post_data(CS%id_cdiss, CS%c_diss, CS%diag) + call cpu_clock_end(CS%id_clock_post) - sh_xx(:,:) = 0. - sh_xy(:,:) = 0. - vort_xy(:,:) = 0. - S_12(:,:) = 0. - S_11(:,:) = 0. - S_22(:,:) = 0. - ssd_11(:,:) = 0. - ssd_12(:,:) = 0. - - ! Calculate horizontal tension (line 590 of MOM_hor_visc.F90) - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - dudx(i,j) = DY_dxT(i,j)*(G%IdyCu(I,j) * u(I,j,k) - & - G%IdyCu(I-1,j) * u(I-1,j,k)) - dvdy(i,j) = DX_dyT(i,j)*(G%IdxCv(i,J) * v(i,J,k) - & - G%IdxCv(i,J-1) * v(i,J-1,k)) - sh_xx(i,j) = dudx(i,j) - dvdy(i,j) ! center of the cell - enddo ; enddo + call cpu_clock_end(CS%id_clock_module) - ! Components for the shearing strain (line 599 of MOM_hor_visc.F90) - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - dvdx(I,J) = DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) - dudy(I,J) = DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) - enddo ; enddo +end subroutine ZB2020_lateral_stress - ! Shearing strain with free-slip B.C. (line 751 of MOM_hor_visc.F90) - ! We use free-slip as cannot guarantee that non-diagonal stress - ! will accelerate or decelerate currents - ! Note that as there is no stencil operator, set of indices - ! is identical to the previous loop, compared to MOM_hor_visc.F90 - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - sh_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) + dudy(I,J) ) ! corner of the cell - enddo ; enddo +!> Compute the attenuation parameter similarly +!! to Klower2018, Juricke2019,2020: c_diss = 1/(1+(shear/(f*R_diss))) +!! where shear = sqrt(sh_xx**2 + sh_xy**2) or shear = sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) +!! In symmetric memory model, components of velocity gradient tensor +!! should have halo 1 and zero boundary conditions. The result: c_diss having halo 1. +subroutine compute_c_diss(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. - ! Relative vorticity with free-slip B.C. (line 789 of MOM_hor_visc.F90) - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) ! corner of the cell - enddo ; enddo + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n - call compute_masks(G, GV, h, mask_T, mask_q, k) - if (CS%id_maskT>0) then - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - mask_T_3d(i,j,k) = mask_T(i,j) - enddo; enddo - endif + real :: shear ! Shear in Klower2018 formula at h points [T-1 ~> s-1] - if (CS%id_maskq>0) then - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - mask_q_3d(i,j,k) = mask_q(i,j) - enddo; enddo - endif + if (.not. CS%Klower_R_diss > 0) & + return - ! Numerical scheme for ZB2020 requires - ! interpolation center <-> corner - ! This interpolation requires B.C., - ! and that is why B.C. for Velocity Gradients should be - ! well defined - ! The same B.C. will be used by all filtering operators - do J=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+2 - sh_xx(i,j) = sh_xx(i,j) * mask_T(i,j) - enddo ; enddo + call cpu_clock_begin(CS%id_clock_cdiss) - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - sh_xy(i,j) = sh_xy(i,j) * mask_q(i,j) - vort_xy(i,j) = vort_xy(i,j) * mask_q(i,j) - enddo ; enddo + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - if (CS%ssd_iter > -1) then - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - ssd_11(i,j) = sh_xx(i,j) * ssd_11_coef(i,j) - enddo; enddo + do k=1,nz - do J=js-1,Jeq ; do I=is-1,Ieq - ssd_12(I,J) = sh_xy(I,J) * ssd_12_coef(I,J) + ! sqrt(sh_xx**2 + sh_xy**2) + if (CS%Klower_shear == 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + (CS%sh_xy(I-1,J-1,k)**2 + CS%sh_xy(I,J ,k)**2) & + + (CS%sh_xy(I-1,J ,k)**2 + CS%sh_xy(I,J-1,k)**2) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j)) enddo; enddo - if (CS%ssd_iter > 0) then - call filter(G, mask_T, mask_q, -1, CS%ssd_iter, T=ssd_11) - call filter(G, mask_T, mask_q, -1, CS%ssd_iter, q=ssd_12) - endif + ! sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + elseif (CS%Klower_shear == 1) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + ((CS%sh_xy(I-1,J-1,k)**2 + CS%vort_xy(I-1,J-1,k)**2) & + + (CS%sh_xy(I,J,k)**2 + CS%vort_xy(I,J,k)**2)) & + + ((CS%sh_xy(I-1,J,k)**2 + CS%vort_xy(I-1,J,k)**2) & + + (CS%sh_xy(I,J-1,k)**2 + CS%vort_xy(I,J-1,k)**2)) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j)) + enddo; enddo endif - call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, T=sh_xx) - call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, T=sh_xx) + enddo ! end of k loop - call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, q=sh_xy) - call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, q=sh_xy) + call cpu_clock_end(CS%id_clock_cdiss) - call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, q=vort_xy) - call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, q=vort_xy) +end subroutine compute_c_diss - ! Corner to center interpolation (line 901 of MOM_hor_visc.F90) - ! lower index as in loop for sh_xy, but minus 1 - ! upper index is identical - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - sh_xy_center(i,j) = 0.25 * ( (sh_xy(I-1,J-1) + sh_xy(I,J)) & - + (sh_xy(I-1,J) + sh_xy(I,J-1)) ) - vort_xy_center(i,j) = 0.25 * ( (vort_xy(I-1,J-1) + vort_xy(I,J)) & - + (vort_xy(I-1,J) + vort_xy(I,J-1)) ) - enddo ; enddo +!> Compute stress tensor T = +!! (Txx, Txy; +!! Txy, Tyy) +!! Which consists of the deviatoric and trace components, respectively: +!! T = (-vort_xy * sh_xy, vort_xy * sh_xx; +!! vort_xy * sh_xx, vort_xy * sh_xy) + +!! 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2, 0; +!! 0, vort_xy^2 + sh_xy^2 + sh_xx^2) +!! This stress tensor is multiplied by precomputed kappa=-CS%amplitude * G%area: +!! T -> T * kappa +!! The sign of the stress tensor is such that (neglecting h): +!! (du/dt, dv/dt) = div(T) +!! In symmetric memory model: sh_xy and vort_xy should have halo 1 +!! and zero B.C.; sh_xx should have halo 2 and zero B.C. +!! Result: Txx, Tyy, Txy with halo 1 and zero B.C. +subroutine compute_stress(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real :: & + vort_xy_h, & ! Vorticity interpolated to h point [T-1 ~> s-1] + sh_xy_h ! Shearing strain interpolated to h point [T-1 ~> s-1] + + real :: & + sh_xx_q ! Horizontal tension interpolated to q point [T-1 ~> s-1] + + ! Local variables + real :: sum_sq ! 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) in h point [T-2 ~> s-2] + real :: vort_sh ! vort_xy*sh_xy in h point [T-2 ~> s-2] - ! Center to corner interpolation - ! lower index as in loop for sh_xx - ! upper index as in the same loop, but minus 1 - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - sh_xx_corner(I,J) = 0.25 * ( (sh_xx(i+1,j+1) + sh_xx(i,j)) & - + (sh_xx(i+1,j) + sh_xx(i,j+1))) - enddo ; enddo + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n - ! WITH land mask (line 622 of MOM_hor_visc.F90) - ! Use of mask eliminates dependence on the - ! values on land - do j=js-2,je+2 ; do I=Isq-1,Ieq+1 - h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) - enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 - h_v(i,J) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) - enddo ; enddo + logical :: sum_sq_flag ! Flag to compute trace + logical :: vort_sh_scheme_0, vort_sh_scheme_1 ! Flags to compute diagonal trace-free part - ! Line 1187 of MOM_hor_visc.F90 - do J=js-1,Jeq ; do I=is-1,Ieq - h2uq = 4.0 * (h_u(I,j) * h_u(I,j+1)) - h2vq = 4.0 * (h_v(i,J) * h_v(i+1,J)) - hq(I,J) = (2.0 * (h2uq * h2vq)) & - / (h_neglect3 + (h2uq + h2vq) * ((h_u(I,j) + h_u(I,j+1)) + (h_v(i,J) + h_v(i+1,J)))) - enddo ; enddo + call cpu_clock_begin(CS%id_clock_stress) - ! Form S_11 and S_22 tensors - ! Indices - intersection of loops for - ! sh_xy_center and sh_xx - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if (CS%ZB_type == 1) then - sum_sq = 0. - else - sum_sq = 0.5 * & - (vort_xy_center(i,j)**2 + sh_xy_center(i,j)**2 + sh_xx(i,j)**2) - endif + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - if (CS%ZB_type == 2) then - vort_sh = 0. - else - if (CS%ZB_cons == 1) then - vort_sh = 0.25 * ( & - (G%areaBu(I-1,J-1) * vort_xy(I-1,J-1) * sh_xy(I-1,J-1) + & - G%areaBu(I ,J ) * vort_xy(I ,J ) * sh_xy(I ,J )) + & - (G%areaBu(I-1,J ) * vort_xy(I-1,J ) * sh_xy(I-1,J ) + & - G%areaBu(I ,J-1) * vort_xy(I ,J-1) * sh_xy(I ,J-1)) & - ) * G%IareaT(i,j) - else if (CS%ZB_cons == 0) then - vort_sh = vort_xy_center(i,j) * sh_xy_center(i,j) - endif + sum_sq = 0. + vort_sh = 0. + + sum_sq_flag = CS%ZB_type /= 1 + vort_sh_scheme_0 = CS%ZB_type /= 2 .and. CS%ZB_cons == 0 + vort_sh_scheme_1 = CS%ZB_type /= 2 .and. CS%ZB_cons == 1 + + do k=1,nz + + ! compute Txx, Tyy tensor + do j=js-1,je+1 ; do i=is-1,ie+1 + ! It is assumed that B.C. is applied to sh_xy and vort_xy + sh_xy_h = 0.25 * ( (CS%sh_xy(I-1,J-1,k) + CS%sh_xy(I,J,k)) & + + (CS%sh_xy(I-1,J,k) + CS%sh_xy(I,J-1,k)) ) + + vort_xy_h = 0.25 * ( (CS%vort_xy(I-1,J-1,k) + CS%vort_xy(I,J,k)) & + + (CS%vort_xy(I-1,J,k) + CS%vort_xy(I,J-1,k)) ) + + if (sum_sq_flag) then + sum_sq = 0.5 * & + ((vort_xy_h * vort_xy_h & + + sh_xy_h * sh_xy_h) & + + CS%sh_xx(i,j,k) * CS%sh_xx(i,j,k) & + ) endif - k_bc = - CS%amplitude * G%areaT(i,j) - S_11(i,j) = k_bc * (- vort_sh + sum_sq) - S_22(i,j) = k_bc * (+ vort_sh + sum_sq) - enddo ; enddo - ! Form S_12 tensor - ! indices correspond to sh_xx_corner loop - do J=Jsq-1,Jeq ; do I=Isq-1,Ieq - if (CS%ZB_type == 2) then - vort_sh = 0. - else - vort_sh = vort_xy(I,J) * sh_xx_corner(I,J) + if (vort_sh_scheme_0) & + vort_sh = vort_xy_h * sh_xy_h + + if (vort_sh_scheme_1) then + ! It is assumed that B.C. is applied to sh_xy and vort_xy + vort_sh = 0.25 * ( & + ((G%areaBu(I-1,J-1) * CS%vort_xy(I-1,J-1,k)) * CS%sh_xy(I-1,J-1,k) + & + (G%areaBu(I ,J ) * CS%vort_xy(I ,J ,k)) * CS%sh_xy(I ,J ,k)) + & + ((G%areaBu(I-1,J ) * CS%vort_xy(I-1,J ,k)) * CS%sh_xy(I-1,J ,k) + & + (G%areaBu(I ,J-1) * CS%vort_xy(I ,J-1,k)) * CS%sh_xy(I ,J-1,k)) & + ) * G%IareaT(i,j) endif - k_bc = - CS%amplitude * G%areaBu(i,j) - S_12(I,J) = k_bc * vort_sh + + ! B.C. is already applied in kappa_h + CS%Txx(i,j,k) = CS%kappa_h(i,j) * (- vort_sh + sum_sq) + CS%Tyy(i,j,k) = CS%kappa_h(i,j) * (+ vort_sh + sum_sq) + enddo ; enddo - call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, T=S_11) - call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, T=S_22) - call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, q=S_12) + ! Here we assume that Txy is initialized to zero + if (CS%ZB_type /= 2) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + sh_xx_q = 0.25 * ( (CS%sh_xx(i+1,j+1,k) + CS%sh_xx(i,j,k)) & + + (CS%sh_xx(i+1,j,k) + CS%sh_xx(i,j+1,k))) + ! B.C. is already applied in kappa_q + CS%Txy(I,J,k) = CS%kappa_q(I,J) * (CS%vort_xy(I,J,k) * sh_xx_q) - if (CS%ssd_iter>-1) then - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - S_11(i,j) = S_11(i,j) + ssd_11(i,j) - S_22(i,j) = S_22(i,j) - ssd_11(i,j) - enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - S_12(I,J) = S_12(I,J) + ssd_12(I,J) enddo ; enddo endif - if (CS%id_S_11>0) then - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - S_11_3d(i,j,k) = S_11(i,j) - enddo; enddo - endif + enddo ! end of k loop - if (CS%id_S_22>0) then - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - S_22_3d(i,j,k) = S_22(i,j) - enddo; enddo - endif + call cpu_clock_end(CS%id_clock_stress) + +end subroutine compute_stress + +!> Compute the divergence of subgrid stress +!! weighted with thickness, i.e. +!! (fx,fy) = 1/h Div(h * [Txx, Txy; Txy, Tyy]) +!! and update the acceleration due to eddy viscosity as +!! diffu = diffu + dx; diffv = diffv + dy +!! Optionally, before computing the divergence, we attenuate the stress +!! according to the Klower formula. +!! In symmetric memory model: Txx, Tyy, Txy, c_diss should have halo 1 +!! with applied zero B.C. +subroutine compute_stress_divergence(u, v, h, diffu, diffv, dx2h, dy2h, dx2q, dy2q, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: diffu !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: diffv !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + Mxx, & ! Subgrid stress Txx multiplied by thickness and dy^2 [H L4 T-2 ~> m5 s-2] + Myy ! Subgrid stress Tyy multiplied by thickness and dx^2 [H L4 T-2 ~> m5 s-2] + + real, dimension(SZIB_(G),SZJB_(G)) :: & + Mxy ! Subgrid stress Txy multiplied by thickness [H L2 T-2 ~> m3 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + ZB2020u !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + ZB2020v !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] + + real :: h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. + real :: h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. + real :: fx ! Zonal acceleration [L T-2 ~> m s-2] + real :: fy ! Meridional acceleration [L T-2 ~> m s-2] + + real :: h_neglect ! Thickness so small it can be lost in + ! roundoff and so neglected [H ~> m or kg m-2] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + logical :: save_ZB2020u, save_ZB2020v ! Save the acceleration due to ZB2020 model + + call cpu_clock_begin(CS%id_clock_divergence) + + save_ZB2020u = (CS%id_ZB2020u > 0) .or. (CS%id_KE_ZB2020 > 0) + save_ZB2020v = (CS%id_ZB2020v > 0) .or. (CS%id_KE_ZB2020 > 0) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - if (CS%id_S_12>0) then + h_neglect = GV%H_subroundoff + + do k=1,nz + if (CS%Klower_R_diss > 0) then do J=js-1,Jeq ; do I=is-1,Ieq - S_12_3d(I,J,k) = S_12(I,J) - enddo; enddo + Mxy(I,J) = (CS%Txy(I,J,k) * & + (0.25 * ( (CS%c_diss(i,j ,k) + CS%c_diss(i+1,j+1,k)) & + + (CS%c_diss(i,j+1,k) + CS%c_diss(i+1,j ,k))) & + ) & + ) * CS%hq(I,J,k) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Mxy(I,J) = CS%Txy(I,J,k) * CS%hq(I,J,k) + enddo ; enddo endif - ! Weight with interface height (Line 1478 of MOM_hor_visc.F90) - ! Note that reduction is removed - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - S_11(i,j) = S_11(i,j) * h(i,j,k) - S_22(i,j) = S_22(i,j) * h(i,j,k) - enddo ; enddo - - ! Free slip (Line 1487 of MOM_hor_visc.F90) - do J=js-1,Jeq ; do I=is-1,Ieq - S_12(I,J) = S_12(I,J) * (hq(I,J) * G%mask2dBu(I,J)) - enddo ; enddo + if (CS%Klower_R_diss > 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + endif ! Evaluate 1/h x.Div(h S) (Line 1495 of MOM_hor_visc.F90) ! Minus occurs because in original file (du/dt) = - div(S), ! but here is the discretization of div(S) do j=js,je ; do I=Isq,Ieq - fx(I,j,k) = - ((G%IdyCu(I,j)*(dy2h(i,j) *S_11(i,j) - & - dy2h(i+1,j)*S_11(i+1,j)) + & - G%IdxCu(I,j)*(dx2q(I,J-1)*S_12(I,J-1) - & - dx2q(I,J) *S_12(I,J))) * & - G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) + h_u = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + h_neglect + fx = -((G%IdyCu(I,j)*(Mxx(i,j) - & + Mxx(i+1,j)) + & + G%IdxCu(I,j)*(dx2q(I,J-1)*Mxy(I,J-1) - & + dx2q(I,J) *Mxy(I,J))) * & + G%IareaCu(I,j)) / h_u + diffu(I,j,k) = diffu(I,j,k) + fx + if (save_ZB2020u) & + ZB2020u(I,j,k) = fx enddo ; enddo ! Evaluate 1/h y.Div(h S) (Line 1517 of MOM_hor_visc.F90) do J=Jsq,Jeq ; do i=is,ie - fy(i,J,k) = - ((G%IdyCv(i,J)*(dy2q(I-1,J)*S_12(I-1,J) - & - dy2q(I,J) *S_12(I,J)) + & ! NOTE this plus - G%IdxCv(i,J)*(dx2h(i,j) *S_22(i,j) - & - dx2h(i,j+1)*S_22(i,j+1))) * & - G%IareaCv(i,J)) / (h_v(i,J) + h_neglect) + h_v = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + h_neglect + fy = -((G%IdyCv(i,J)*(dy2q(I-1,J)*Mxy(I-1,J) - & + dy2q(I,J) *Mxy(I,J)) + & ! NOTE this plus + G%IdxCv(i,J)*(Myy(i,j) - & + Myy(i,j+1))) * & + G%IareaCv(i,J)) / h_v + diffv(i,J,k) = diffv(i,J,k) + fy + if (save_ZB2020v) & + ZB2020v(i,J,k) = fy enddo ; enddo enddo ! end of k loop - if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, fx, CS%diag) - if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, fy, CS%diag) - - if (CS%id_maskT>0) call post_data(CS%id_maskT, mask_T_3d, CS%diag) - if (CS%id_maskq>0) call post_data(CS%id_maskq, mask_q_3d, CS%diag) - - if (CS%id_S_11>0) call post_data(CS%id_S_11, S_11_3d, CS%diag) - - if (CS%id_S_22>0) call post_data(CS%id_S_22, S_22_3d, CS%diag) - - if (CS%id_S_12>0) call post_data(CS%id_S_12, S_12_3d, CS%diag) - - call compute_energy_source(u, v, h, fx, fy, G, GV, CS) - -end subroutine Zanna_Bolton_2020 - -!> Filter which is used to smooth velocity gradient tensor -!! or the stress tensor. -!! If n_lowpass and n_highpass are positive, -!! the filter is given by: -!! I - (I-G^n_lowpass)^n_highpass -!! where I is the identity matrix and G is smooth_Tq(). -!! It is filter of order 2*n_highpass, -!! where n_lowpass is the number of iterations -!! which defines the filter scale. -!! If n_lowpass is negative, returns residual -!! for the same filter: -!! (I-G^|n_lowpass|)^n_highpass -!! Input does not require halo. Output has full halo. -subroutine filter(G, mask_T, mask_q, n_lowpass, n_highpass, T, q) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - integer, intent(in) :: n_lowpass !< number of low-pass iterations - integer, intent(in) :: n_highpass !< number of high-pass iterations - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: mask_T !< mask of wet points in T (CENTER) points [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(in) :: mask_q !< mask of wet points in q (CORNER) points [nondim] - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: T !< any field at T (CENTER) points [arbitrary] - real, dimension(SZIB_(G),SZJB_(G)), & - optional, intent(inout) :: q !< any field at q (CORNER) points [arbitrary] + call cpu_clock_end(CS%id_clock_divergence) - real, dimension(SZIB_(G),SZJB_(G)) :: q1, q2 ! intermediate q-fields [arbitrary] - real, dimension(SZI_(G),SZJ_(G)) :: T1, T2 ! intermediate T-fields [arbitrary] - real :: max_before, min_before, max_after, min_after ! minimum and maximum values of fields - ! before and after filtering [arbitrary] + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, ZB2020u, CS%diag) + if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, ZB2020v, CS%diag) + call cpu_clock_end(CS%id_clock_post) - integer :: i_highpass, i_lowpass - integer :: i, j - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + call compute_energy_source(u, v, h, ZB2020u, ZB2020v, G, GV, CS) - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB +end subroutine compute_stress_divergence - if (n_lowpass==0) then - return - endif +!> Filtering of the velocity gradients sh_xx, sh_xy, vort_xy. +!! Here instead of smoothing we do sharpening, i.e. +!! return (initial - smoothed) fields. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input array sh_xx should have halo 2 with +!! applied zero B.C. The arrays sh_xy and vort_xy should have +!! halo 1 with applied B.C. The output have the same halo and B.C. +subroutine filter_velocity_gradients(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. - ! Total operator is I - (I-G^n_lowpass)^n_highpass - if (present(q)) then - call pass_var(q, G%Domain, position=CORNER, complete=.true.) - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q(I,J) = q(I,J) * mask_q(I,J) - enddo ; enddo + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + sh_xx ! Copy of CS%sh_xx [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + sh_xy, vort_xy ! Copy of CS%sh_xy and CS%vort_xy [T-1 ~> s-1] - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_before, max_before, q=q) - endif + integer :: xx_halo, xy_halo, vort_halo ! currently available halo for gradient components + integer :: xx_iter, xy_iter, vort_iter ! remaining number of iterations + integer :: niter ! required number of iterations - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q1(I,J) = q(I,J) - enddo ; enddo + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n - ! q1 -> ((I-G^n_lowpass)^n_highpass)*q1 - do i_highpass=1,n_highpass - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q2(I,J) = q1(I,J) - enddo ; enddo - ! q2 -> (G^n_lowpass)*q2 - do i_lowpass=1,ABS(n_lowpass) - call smooth_Tq(G, mask_T, mask_q, q=q2) - enddo - ! q1 -> (I-G^n_lowpass)*q1 - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q1(I,J) = q1(I,J) - q2(I,J) - enddo ; enddo - enddo + niter = CS%HPF_iter - if (n_lowpass>0) then - ! q -> q - ((I-G^n_lowpass)^n_highpass)*q - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q(I,J) = q(I,J) - q1(I,J) - enddo ; enddo - else - ! q -> ((I-G^n_lowpass)^n_highpass)*q - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q(I,J) = q1(I,J) - enddo ; enddo - endif + if (niter == 0) return - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_after, max_after, q=q) - if (max_after > max_before .OR. min_after < min_before) then - call MOM_error(WARNING, "MOM_Zanna_Bolton.F90, filter applied in CORNER points "//& - "does not preserve [min,max] values. There may be issues with "//& - "boundary conditions") - endif - endif - endif + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - if (present(T)) then - call pass_var(T, G%Domain) - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T(i,j) = T(i,j) * mask_T(i,j) - enddo ; enddo + if (.not. G%symmetric) & + call do_group_pass(CS%pass_xx, G%Domain, & + clock=CS%id_clock_mpi) - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_before, max_before, T=T) - endif + ! This is just copy of the array + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + ! Halo of size 2 is valid + do j=js-2,je+2; do i=is-2,ie+2 + sh_xx(i,j,k) = CS%sh_xx(i,j,k) + enddo; enddo + ! Only halo of size 1 is valid + do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1 + sh_xy(I,J,k) = CS%sh_xy(I,J,k) + vort_xy(I,J,k) = CS%vort_xy(I,J,k) + enddo; enddo + enddo + call cpu_clock_end(CS%id_clock_filter) - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T1(i,j) = T(i,j) - enddo ; enddo + xx_halo = 2; xy_halo = 1; vort_halo = 1; + xx_iter = niter; xy_iter = niter; vort_iter = niter; - do i_highpass=1,n_highpass - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T2(i,j) = T1(i,j) - enddo ; enddo - do i_lowpass=1,ABS(n_lowpass) - call smooth_Tq(G, mask_T, mask_q, T=T2) - enddo - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T1(i,j) = T1(i,j) - T2(i,j) - enddo ; enddo - enddo + do while & + (xx_iter > 0 .or. xy_iter > 0 .or. & ! filter iterations remain to be done + xx_halo < 2 .or. xy_halo < 1) ! there is no halo for VG tensor - if (n_lowpass>0) then - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T(i,j) = T(i,j) - T1(i,j) - enddo ; enddo - else - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T(i,j) = T1(i,j) - enddo ; enddo + ! ---------- filtering sh_xx --------- + if (xx_halo < 2) then + call complete_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) + xx_halo = CS%HPF_halo endif - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_after, max_after, T=T) - if (max_after > max_before .OR. min_after < min_before) then - call MOM_error(WARNING, "MOM_Zanna_Bolton.F90, filter applied in CENTER points "//& - " does not preserve [min,max] values. There may be issues with "//& - " boundary conditions") - endif - endif - endif -end subroutine filter - -!> One iteration of 3x3 filter -!! [1 2 1; -!! 2 4 2; -!! 1 2 1]/16 -!! removing chess-harmonic. -!! It is used as a buiding block in filter(). -!! Zero Dirichlet boundary conditions are applied -!! with mask_T and mask_q. -subroutine smooth_Tq(G, mask_T, mask_q, T, q) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: mask_T !< mask of wet points in T (CENTER) points [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(in) :: mask_q !< mask of wet points in q (CORNER) points [nondim] - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: T !< any field at T (CENTER) points [arbitrary] - real, dimension(SZIB_(G),SZJB_(G)), & - optional, intent(inout) :: q !< any field at q (CORNER) points [arbitrary] + call filter_hq(G, GV, CS, xx_halo, xx_iter, h=CS%sh_xx) - real, dimension(SZI_(G),SZJ_(G)) :: Tim ! intermediate T-field [arbitrary] - real, dimension(SZIB_(G),SZJB_(G)) :: qim ! intermediate q-field [arbitrary] + if (xx_halo < 2) & + call start_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) - real :: wside ! weights for side points - ! (i+1,j), (i-1,j), (i,j+1), (i,j-1) - ! [nondim] - real :: wcorner ! weights for corner points - ! (i+1,j+1), (i+1,j-1), (i-1,j-1), (i-1,j+1) - ! [nondim] - real :: wcenter ! weight for the center point (i,j) [nondim] + ! ------ filtering sh_xy, vort_xy ---- + if (xy_halo < 1) then + call complete_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) + xy_halo = CS%HPF_halo; vort_halo = CS%HPF_halo + endif - integer :: i, j - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + call filter_hq(G, GV, CS, xy_halo, xy_iter, q=CS%sh_xy) + call filter_hq(G, GV, CS, vort_halo, vort_iter, q=CS%vort_xy) - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + if (xy_halo < 1) & + call start_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) - wside = 1. / 8. - wcorner = 1. / 16. - wcenter = 1. - (wside*4. + wcorner*4.) + enddo - if (present(q)) then - call pass_var(q, G%Domain, position=CORNER, complete=.true.) - do J = Jsq-1, Jeq+1; do I = Isq-1, Ieq+1 - qim(I,J) = q(I,J) * mask_q(I,J) + ! We implement sharpening by computing residual + ! B.C. are already applied to all fields + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + do j=js-2,je+2; do i=is-2,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j,k) - CS%sh_xx(i,j,k) enddo; enddo - do J = Jsq, Jeq - do I = Isq, Ieq - q(I,J) = wcenter * qim(i,j) & - + wcorner * ( & - (qim(I-1,J-1)+qim(I+1,J+1)) & - + (qim(I-1,J+1)+qim(I+1,J-1)) & - ) & - + wside * ( & - (qim(I-1,J)+qim(I+1,J)) & - + (qim(I,J-1)+qim(I,J+1)) & - ) - q(I,J) = q(I,J) * mask_q(I,J) - enddo - enddo - call pass_var(q, G%Domain, position=CORNER, complete=.true.) - endif - - if (present(T)) then - call pass_var(T, G%Domain) - do j = js-1, je+1; do i = is-1, ie+1 - Tim(i,j) = T(i,j) * mask_T(i,j) + do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J,k) - CS%sh_xy(I,J,k) + CS%vort_xy(I,J,k) = vort_xy(I,J,k) - CS%vort_xy(I,J,k) enddo; enddo - do j = js, je - do i = is, ie - T(i,j) = wcenter * Tim(i,j) & - + wcorner * ( & - (Tim(i-1,j-1)+Tim(i+1,j+1)) & - + (Tim(i-1,j+1)+Tim(i+1,j-1)) & - ) & - + wside * ( & - (Tim(i-1,j)+Tim(i+1,j)) & - + (Tim(i,j-1)+Tim(i,j+1)) & - ) - T(i,j) = T(i,j) * mask_T(i,j) - enddo - enddo - call pass_var(T, G%Domain) - endif + enddo + call cpu_clock_end(CS%id_clock_filter) -end subroutine smooth_Tq + if (.not. G%symmetric) & + call do_group_pass(CS%pass_xy, G%Domain, & + clock=CS%id_clock_mpi) -!> Returns min and max values of array across all PEs. -!! It is used in filter() to check its monotonicity. -subroutine min_max(G, min_val, max_val, T, q) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: T !< any field at T (CENTER) points [arbitrary] - real, dimension(SZIB_(G),SZJB_(G)), & - optional, intent(inout) :: q !< any field at q (CORNER) points [arbitrary] - real, intent(out) :: min_val, max_val !< min and max values of array accross PEs [arbitrary] +end subroutine filter_velocity_gradients - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq +!> Filtering of the stress tensor Txx, Tyy, Txy. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input arrays (Txx, Tyy, Txy) must have halo 1 +!! with zero B.C. applied. The output have the same halo and B.C. +subroutine filter_stress(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + integer :: Txx_halo, Tyy_halo, Txy_halo ! currently available halo for stress components + integer :: Txx_iter, Tyy_iter, Txy_iter ! remaining number of iterations + integer :: niter ! required number of iterations - if (present(q)) then - min_val = minval(q(Isq:Ieq, Jsq:Jeq)) - max_val = maxval(q(Isq:Ieq, Jsq:Jeq)) - endif + niter = CS%Stress_iter - if (present(T)) then - min_val = minval(T(is:ie, js:je)) - max_val = maxval(T(is:ie, js:je)) - endif + if (niter == 0) return - call min_across_PEs(min_val) - call max_across_PEs(max_val) - -end subroutine - -!> Computes mask of wet points in T (CENTER) and q (CORNER) points. -!! Method: compare layer thicknesses with Angstrom_H. -!! Mask is computed separately for every vertical layer and -!! for every time step. -subroutine compute_masks(G, GV, h, mask_T, mask_q, k) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)), & - intent(inout) :: mask_T !< mask of wet points in T (CENTER) points [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: mask_q !< mask of wet points in q (CORNER) points [nondim] - integer, intent(in) :: k !< index of vertical layer - - real :: hmin ! Minimum layer thickness - ! beyond which we have boundary [H ~> m or kg m-2] - integer :: i, j + Txx_halo = 1; Tyy_halo = 1; Txy_halo = 1; ! these are required halo for Txx, Tyy, Txy + Txx_iter = niter; Tyy_iter = niter; Txy_iter = niter; + + do while & + (Txx_iter > 0 .or. Txy_iter > 0 .or. & ! filter iterations remain to be done + Txx_halo < 1 .or. Txy_halo < 1) ! there is no halo for Txx or Txy + + ! ---------- filtering Txy ----------- + if (Txy_halo < 1) then + call complete_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + Txy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txy_halo, Txy_iter, q=CS%Txy) + + if (Txy_halo < 1) & + call start_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + + ! ------- filtering Txx, Tyy --------- + if (Txx_halo < 1) then + call complete_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) + Txx_halo = CS%Stress_halo; Tyy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txx_halo, Txx_iter, h=CS%Txx) + call filter_hq(G, GV, CS, Tyy_halo, Tyy_iter, h=CS%Tyy) + + if (Txx_halo < 1) & + call start_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) - hmin = GV%Angstrom_H * 2. - - mask_q(:,:) = 0. - do J = G%JscB, G%JecB - do I = G%IscB, G%IecB - if (h(i+1,j+1,k) < hmin .or. & - h(i ,j ,k) < hmin .or. & - h(i+1,j ,k) < hmin .or. & - h(i ,j+1,k) < hmin & - ) then - mask_q(I,J) = 0. - else - mask_q(I,J) = 1. - endif - mask_q(I,J) = mask_q(I,J) * G%mask2dBu(I,J) - enddo enddo - call pass_var(mask_q, G%Domain, position=CORNER, complete=.true.) - mask_T(:,:) = 0. - do j = G%jsc, G%jec - do i = G%isc, G%iec - if (h(i,j,k) < hmin) then - mask_T(i,j) = 0. +end subroutine filter_stress + +!> Wrapper for filter_3D function. The border indices for q and h +!! arrays are substituted. +subroutine filter_hq(G, GV, CS, current_halo, remaining_iterations, q, h) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, & + intent(inout) :: h !< Input/output array in h points [arbitrary] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), optional, & + intent(inout) :: q !< Input/output array in q points [arbitrary] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + + logical :: direction ! The direction of the first 1D filter + + direction = (MOD(G%first_direction,2) == 0) + + call cpu_clock_begin(CS%id_clock_filter) + + if (present(h)) then + call filter_3D(h, CS%maskw_h, & + G%isd, G%ied, G%jsd, G%jed, & + G%isc, G%iec, G%jsc, G%jec, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + if (present(q)) then + call filter_3D(q, CS%maskw_q, & + G%IsdB, G%IedB, G%JsdB, G%JedB, & + G%IscB, G%IecB, G%JscB, G%JecB, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + call cpu_clock_end(CS%id_clock_filter) +end subroutine filter_hq + +!> Spatial lateral filter applied to 3D array. The lateral filter is given +!! by the convolutional kernel: +!! [1 2 1] +!! C = |2 4 2| * 1/16 +!! [1 2 1] +!! The fast algorithm decomposes the 2D filter into two 1D filters as follows: +!! [1] +!! C = |2| * [1 2 1] * 1/16 +!! [1] +!! The input array must have zero B.C. applied. B.C. is applied for output array. +!! Note that maskw contains both land mask and 1/16 factor. +!! Filter implements marching halo. The available halo is specified and as many +!! filter iterations as possible and as needed are performed. +subroutine filter_3D(x, maskw, isd, ied, jsd, jed, is, ie, js, je, nz, & + current_halo, remaining_iterations, & + direction) + integer, intent(in) :: isd !< Indices of array size + integer, intent(in) :: ied !< Indices of array size + integer, intent(in) :: jsd !< Indices of array size + integer, intent(in) :: jed !< Indices of array size + integer, intent(in) :: is !< Indices of owned points + integer, intent(in) :: ie !< Indices of owned points + integer, intent(in) :: js !< Indices of owned points + integer, intent(in) :: je !< Indices of owned points + integer, intent(in) :: nz !< Vertical array size + real, dimension(isd:ied,jsd:jed,nz), & + intent(inout) :: x !< Input/output array [arbitrary] + real, dimension(isd:ied,jsd:jed), & + intent(in) :: maskw !< Mask array of land points divided by 16 [nondim] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + logical, intent(in) :: direction !< The direction of the first 1D filter + + real, parameter :: weight = 2. ! Filter weight [nondim] + integer :: i, j, k, iter, niter, halo + + real :: tmp(isd:ied, jsd:jed) ! Array with temporary results [arbitrary] + + ! Do as many iterations as needed and possible + niter = min(current_halo, remaining_iterations) + if (niter == 0) return ! nothing to do + + ! Update remaining iterations + remaining_iterations = remaining_iterations - niter + ! Update halo information + current_halo = current_halo - niter + + do k=1,Nz + halo = niter-1 + & + current_halo ! Save as many halo points as possible + do iter=1,niter + + if (direction) then + do j = js-halo, je+halo; do i = is-halo-1, ie+halo+1 + tmp(i,j) = weight * x(i,j,k) + (x(i,j-1,k) + x(i,j+1,k)) + enddo; enddo + + do j = js-halo, je+halo; do i = is-halo, ie+halo; + x(i,j,k) = (weight * tmp(i,j) + (tmp(i-1,j) + tmp(i+1,j))) * maskw(i,j) + enddo; enddo else - mask_T(i,j) = 1. + do j = js-halo-1, je+halo+1; do i = is-halo, ie+halo + tmp(i,j) = weight * x(i,j,k) + (x(i-1,j,k) + x(i+1,j,k)) + enddo; enddo + + do j = js-halo, je+halo; do i = is-halo, ie+halo; + x(i,j,k) = (weight * tmp(i,j) + (tmp(i,j-1) + tmp(i,j+1))) * maskw(i,j) + enddo; enddo endif - mask_T(i,j) = mask_T(i,j) * G%mask2dT(i,j) + + halo = halo - 1 enddo enddo - call pass_var(mask_T, G%Domain) -end subroutine compute_masks +end subroutine filter_3D !> Computes the 3D energy source term for the ZB2020 scheme !! similarly to MOM_diagnostics.F90, specifically 1125 line. @@ -906,7 +1032,7 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: fx !< Zonal acceleration due to convergence of @@ -922,11 +1048,6 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] - !real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! temporary array for integration - !real :: global_integral ! Global integral of the energy effect of ZB2020 - ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] - - real :: uh ! Transport through zonal faces = u*h*dy, ! [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: vh ! Transport through meridional faces = v*h*dx, @@ -937,14 +1058,14 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - if (CS%id_KE_ZB2020 > 0) then + call cpu_clock_begin(CS%id_clock_source) call create_group_pass(pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + KE_term(:,:,:) = 0. - !tmp(:,:,:) = 0. ! Calculate the KE source from Zanna-Bolton2020 [H L2 T-3 ~> m3 s-3]. do k=1,nz KE_u(:,:) = 0. @@ -963,14 +1084,14 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) do j=js,je ; do i=is,ie KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) - ! copy-paste from MOM_spatial_means.F90, line 42 - !tmp(i,j,k) = KE_term(i,j,k) * G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo enddo - !global_integral = reproducing_sum(tmp) + call cpu_clock_end(CS%id_clock_source) + call cpu_clock_begin(CS%id_clock_post) call post_data(CS%id_KE_ZB2020, KE_term, CS%diag) + call cpu_clock_end(CS%id_clock_post) endif end subroutine compute_energy_source diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2d1c38abf9..732044c34e 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -23,7 +23,8 @@ module MOM_hor_visc use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_variables, only : accel_diag_ptrs -use MOM_Zanna_Bolton, only : Zanna_Bolton_2020, ZB_2020_init, ZB2020_CS +use MOM_Zanna_Bolton, only : ZB2020_lateral_stress, ZB2020_init, ZB2020_end, & + ZB2020_CS, ZB2020_copy_gradient_and_thickness implicit none ; private @@ -250,7 +251,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! related to Mesoscale Eddy Kinetic Energy. type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control structure + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type type(barotropic_CS), intent(in), optional :: BT !< Barotropic control structure type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control structure @@ -334,16 +335,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grid_Re_Ah, & ! Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] GME_coeff_h ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] - ! Zanna-Bolton fields - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & - ZB2020u !< Zonal acceleration due to convergence of - !! along-coordinate stress tensor for ZB model - !! [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & - ZB2020v !< Meridional acceleration due to convergence - !! of along-coordinate stress tensor for ZB model - !! [L T-2 ~> m s-2] - real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Shear_mag_bc ! Shear_mag value in backscatter [T-1 ~> s-1] @@ -1217,6 +1208,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + ! Pass the velocity gradients and thickness to ZB2020 + if (CS%use_ZB2020) then + call ZB2020_copy_gradient_and_thickness( & + sh_xx, sh_xy, vort_xy, & + hq, & + G, GV, CS%ZB2020, k) + endif + if (CS%Laplacian) then if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then if (CS%use_QG_Leith_visc) then @@ -1622,18 +1621,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ! end of k loop - if (CS%use_ZB2020) then - call Zanna_Bolton_2020(u, v, h, ZB2020u, ZB2020v, G, GV, CS%ZB2020) - - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - diffu(I,j,k) = diffu(I,j,k) + ZB2020u(I,j,k) - enddo ; enddo ; enddo - - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - diffv(i,J,k) = diffv(i,J,k) + ZB2020v(i,J,k) - enddo ; enddo ; enddo - endif - ! Offer fields for diagnostic averaging. if (CS%id_normstress > 0) call post_data(CS%id_normstress, NoSt, CS%diag) if (CS%id_shearstress > 0) call post_data(CS%id_shearstress, ShSt, CS%diag) @@ -1703,6 +1690,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_diffv_visc_rem > 0) call post_product_v(CS%id_diffv_visc_rem, diffv, ADp%visc_rem_v, G, nz, CS%diag) endif + if (CS%use_ZB2020) then + call ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS%ZB2020, & + CS%dx2h, CS%dy2h, CS%dx2q, CS%dy2q) + endif + end subroutine horizontal_viscosity !> Allocates space for and calculates static variables used by horizontal_viscosity(). @@ -1777,7 +1769,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! init control structure - call ZB_2020_init(Time, GV, US, param_file, diag, CS%ZB2020, CS%use_ZB2020) + call ZB2020_init(Time, G, GV, US, param_file, diag, CS%ZB2020, CS%use_ZB2020) CS%initialized = .true. @@ -2691,6 +2683,11 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%n1n1_m_n2n2_h) DEALLOC_(CS%n1n1_m_n2n2_q) endif + + if (CS%use_ZB2020) then + call ZB2020_end(CS%ZB2020) + endif + end subroutine hor_visc_end !> \namespace mom_hor_visc !! From ac66061e14a670b0112f1790b53046fcca4a9276 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Mon, 23 Oct 2023 14:40:51 -0400 Subject: [PATCH 121/146] Ice-shelf solo driver and MISMIP+ updates (#471) - Several edits to the ice shelf solo driver so that it works with the rest of the current MOM6 - Added capability to initialize a surface mass balance (SMB) that is held contstant over time when running from the ice-shelf solo driver (see new subroutine initialize_ice_SMB). This is required for MISMIP+. A constant SMB can also be used from the MOM driver for coupled ice-shelf/ocean experiments (e.g. MISOMIP). - The new, constant SMB is passed into solo_step_ice_shelf, where change_thickness_using_precip is called - Added capability to save both non-time-stamped and time-stamped restart files when using the ice shelf solo driver. This is useful for debugging. - slight reorganization to when ice shelf post_data calls are made - Added safety checks to diag_mediator_end() so that it works with the ice shelf solo-driver, which now calls it instead of (now removed) solo_ice_shelf_diag_mediator_end() routine. Removed the runtime parameter SAVE_BOTH_RESTARTS from the ice shelf solo-driver, which is no longer needed. --- .../ice_solo_driver/ice_shelf_driver.F90 | 48 +++++++++++--- config_src/drivers/solo_driver/MOM_driver.F90 | 6 +- src/framework/MOM_diag_mediator.F90 | 64 +++++++++++-------- src/ice_shelf/MOM_ice_shelf.F90 | 20 ++++-- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 49 +++++++++++++- 6 files changed, 141 insertions(+), 48 deletions(-) diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index 8ea0867d03..f91595bd51 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -24,7 +24,7 @@ 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_debugging, only : MOM_debugging_init - use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init + use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init, set_axes_info use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration use MOM_domains, only : MOM_infra_init, MOM_infra_end use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var @@ -54,6 +54,8 @@ program Shelf_main use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + use MOM_forcing_type, only : forcing + use MOM_ice_shelf_initialize, only : initialize_ice_SMB use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf @@ -75,7 +77,9 @@ program Shelf_main ! CPU time limit. nmax is determined by evaluating the CPU time used between successive calls to ! write_cputime. Initially it is set to be very large. integer :: nmax=2000000000 - + ! A structure containing pointers to the thermodynamic forcing fields + ! at the ocean surface. + type(forcing) :: fluxes ! A structure containing several relevant directory paths. type(directories) :: dirs @@ -104,7 +108,7 @@ program Shelf_main real :: time_step ! The time step [T ~> s] ! A pointer to a structure containing metrics and related information. - type(ocean_grid_type), pointer :: ocn_grid + type(ocean_grid_type), pointer :: ocn_grid => NULL() type(dyn_horgrid_type), pointer :: dG => NULL() ! A dynamic version of the horizontal grid type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents @@ -114,7 +118,7 @@ program Shelf_main type(ocean_OBC_type), pointer :: OBC => NULL() ! A pointer to a structure containing dimensional unit scaling factors. - type(unit_scale_type), pointer :: US + type(unit_scale_type), pointer :: US => NULL() type(diag_ctrl), pointer :: & diag => NULL() ! A pointer to the diagnostic regulatory structure @@ -138,8 +142,9 @@ program Shelf_main 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. + real :: smb !A constant surface mass balance that can be specified in the param_file character(len=9) :: month - character(len=16) :: calendar = 'julian' + character(len=16) :: calendar = 'noleap' integer :: calendar_type=-1 integer :: unit, io_status, ierr @@ -184,6 +189,8 @@ program Shelf_main endif endif + ! Get the names of the I/O directories and initialization file. + ! Also calls the subroutine that opens run-time parameter files. call Get_MOM_Input(param_file, dirs) ! Read ocean_solo restart, which can override settings from the namelist. @@ -252,8 +259,11 @@ program Shelf_main ! 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) + allocate(ocn_grid) + call MOM_domains_init(ocn_grid%domain, param_file) !, domain_name='MOM') + allocate(HI) call hor_index_init(ocn_grid%Domain, HI, param_file) + allocate(dG) call create_dyn_horgrid(dG, HI) call clone_MOM_domain(ocn_grid%Domain, dG%Domain) @@ -266,11 +276,16 @@ program Shelf_main ! Initialize the diag mediator. The ocean's vertical grid is not really used here, but at ! present the interface to diag_mediator_init assumes the presence of ocean-specific information. call verticalGridInit(param_file, GV, US) + allocate(diag) call diag_mediator_init(ocn_grid, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) call callTree_waypoint("returned from diag_mediator_init()") - call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag) + call set_axes_info(ocn_grid, GV, US, param_file, diag) + + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, fluxes_in=fluxes, solo_ice_sheet_in=.true.) + + call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, ocn_grid, US, param_file) ! This is the end of the code that is the counterpart of MOM_initialization. call callTree_waypoint("End of ice shelf initialization.") @@ -378,7 +393,7 @@ program Shelf_main ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time, fluxes_in=fluxes) ! Time = Time + Time_step_shelf ! This is here to enable fractional-second time steps. @@ -412,6 +427,20 @@ program Shelf_main if (BTEST(Restart_control,0)) then call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) endif + ! Write ice shelf solo restart file. + if (is_root_pe())then + call open_ASCII_file(unit, trim(dirs%restart_output_dir)//'shelf.res') + write(unit, '(i6,8x,a)') calendar_type, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Model start time: year, month, day, hour, minute, second' + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Current model time: year, month, day, hour, minute, second' + call close_file(unit) + endif restart_time = restart_time + restint endif @@ -456,12 +485,11 @@ program Shelf_main endif call callTree_waypoint("End Shelf_main") + call ice_shelf_end(ice_shelf_CSp) call diag_mediator_end(Time, diag, end_diag_manager=.true.) if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end - call ice_shelf_end(ice_shelf_CSp) - end program Shelf_main diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 84c2eec5b5..0e355f8638 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -49,6 +49,7 @@ program MOM6 use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart use MOM_ice_shelf, only : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces use MOM_ice_shelf, only : ice_shelf_query + use MOM_ice_shelf_initialize, only : initialize_ice_SMB use MOM_interpolate, only : time_interp_external_init use MOM_io, only : file_exists, open_ASCII_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end @@ -134,7 +135,7 @@ program MOM6 real :: dtdia ! The diabatic timestep [T ~> s] real :: t_elapsed_seg ! The elapsed time in this run segment [T ~> s] integer :: n, ns, n_max, nts, n_last_thermo - logical :: diabatic_first, single_step_call + logical :: diabatic_first, single_step_call, initialize_smb type(time_type) :: Time2, time_chg ! Temporary time variables integer :: Restart_control ! An integer that is bit-tested to determine whether @@ -302,6 +303,9 @@ program MOM6 call initialize_ice_shelf_forces(ice_shelf_CSp, grid, US, forces) call ice_shelf_query(ice_shelf_CSp, grid, data_override_shelf_fluxes=override_shelf_fluxes) if (override_shelf_fluxes) call data_override_init(Ocean_Domain_in=grid%domain%mpp_domain) + call get_param(param_file, mod_name, "INITIALIZE_ICE_SHEET_SMB", & + initialize_smb, "Read in a constant SMB for the ice sheet", default=.false.) + if (initialize_smb) call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, grid, US, param_file) endif diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 61290cb579..2c71a93e42 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3539,37 +3539,45 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) enddo call diag_grid_storage_end(diag_cs%diag_grid_temp) - deallocate(diag_cs%mask3dTL) - deallocate(diag_cs%mask3dBL) - deallocate(diag_cs%mask3dCuL) - deallocate(diag_cs%mask3dCvL) - deallocate(diag_cs%mask3dTi) - deallocate(diag_cs%mask3dBi) - deallocate(diag_cs%mask3dCui) - deallocate(diag_cs%mask3dCvi) + if (associated(diag_cs%mask3dTL)) deallocate(diag_cs%mask3dTL) + if (associated(diag_cs%mask3dBL)) deallocate(diag_cs%mask3dBL) + if (associated(diag_cs%mask3dCuL)) deallocate(diag_cs%mask3dCuL) + if (associated(diag_cs%mask3dCvL)) deallocate(diag_cs%mask3dCvL) + if (associated(diag_cs%mask3dTi)) deallocate(diag_cs%mask3dTi) + if (associated(diag_cs%mask3dBi)) deallocate(diag_cs%mask3dBi) + if (associated(diag_cs%mask3dCui)) deallocate(diag_cs%mask3dCui) + if (associated(diag_cs%mask3dCvi)) deallocate(diag_cs%mask3dCvi) do dl=2,MAX_DSAMP_LEV - deallocate(diag_cs%dsamp(dl)%mask2dT) - deallocate(diag_cs%dsamp(dl)%mask2dBu) - deallocate(diag_cs%dsamp(dl)%mask2dCu) - deallocate(diag_cs%dsamp(dl)%mask2dCv) - deallocate(diag_cs%dsamp(dl)%mask3dTL) - deallocate(diag_cs%dsamp(dl)%mask3dBL) - deallocate(diag_cs%dsamp(dl)%mask3dCuL) - deallocate(diag_cs%dsamp(dl)%mask3dCvL) - deallocate(diag_cs%dsamp(dl)%mask3dTi) - deallocate(diag_cs%dsamp(dl)%mask3dBi) - deallocate(diag_cs%dsamp(dl)%mask3dCui) - deallocate(diag_cs%dsamp(dl)%mask3dCvi) + if (associated(diag_cs%dsamp(dl)%mask2dT)) deallocate(diag_cs%dsamp(dl)%mask2dT) + if (associated(diag_cs%dsamp(dl)%mask2dBu)) deallocate(diag_cs%dsamp(dl)%mask2dBu) + if (associated(diag_cs%dsamp(dl)%mask2dCu)) deallocate(diag_cs%dsamp(dl)%mask2dCu) + if (associated(diag_cs%dsamp(dl)%mask2dCv)) deallocate(diag_cs%dsamp(dl)%mask2dCv) + if (associated(diag_cs%dsamp(dl)%mask3dTL)) deallocate(diag_cs%dsamp(dl)%mask3dTL) + if (associated(diag_cs%dsamp(dl)%mask3dBL)) deallocate(diag_cs%dsamp(dl)%mask3dBL) + if (associated(diag_cs%dsamp(dl)%mask3dCuL)) deallocate(diag_cs%dsamp(dl)%mask3dCuL) + if (associated(diag_cs%dsamp(dl)%mask3dCvL)) deallocate(diag_cs%dsamp(dl)%mask3dCvL) + if (associated(diag_cs%dsamp(dl)%mask3dTi)) deallocate(diag_cs%dsamp(dl)%mask3dTi) + if (associated(diag_cs%dsamp(dl)%mask3dBi)) deallocate(diag_cs%dsamp(dl)%mask3dBi) + if (associated(diag_cs%dsamp(dl)%mask3dCui)) deallocate(diag_cs%dsamp(dl)%mask3dCui) + if (associated(diag_cs%dsamp(dl)%mask3dCvi)) deallocate(diag_cs%dsamp(dl)%mask3dCvi) do i=1,diag_cs%num_diag_coords - deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) enddo enddo diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index f5a85da95a..7176e3ccdf 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1873,7 +1873,8 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) tau_mag=.true.) else call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") - call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) + call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & + press=.true., shelf_sfc_accumulation = CS%active_shelf_dynamics, tau_mag=.true.) endif if (CS%rotate_index) then allocate(fluxes) @@ -2178,13 +2179,14 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end !> This routine is for stepping a stand-alone ice shelf model without an ocean. -subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in) +subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in, fluxes_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(time_type), intent(in) :: time_interval !< The time interval for this update [s]. integer, intent(inout) :: nsteps !< The running number of ice shelf steps. type(time_type), intent(inout) :: Time !< The current model time real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [T ~> s]. - + type(forcing), optional, target, intent(inout) :: fluxes_in !< A structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors @@ -2192,6 +2194,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in !! the ice-shelf state real :: remaining_time ! The remaining time in this call [T ~> s] real :: time_step ! The internal time step during this call [T ~> s] + real :: full_time_step ! The external time step (sum of internal time steps) during this call [T ~> s] real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] character(len=240) :: mesg logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. @@ -2205,6 +2208,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec remaining_time = US%s_to_T*time_type_to_real(time_interval) + full_time_step = remaining_time if (present (min_time_step_in)) then min_time_step = min_time_step_in @@ -2228,6 +2232,8 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) endif + call change_thickness_using_precip(CS, ISS, G, US, fluxes_in, time_step, Time) + remaining_time = remaining_time - time_step ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. @@ -2237,13 +2243,13 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, must_update_vel=update_ice_vel) - call enable_averages(time_step, Time, CS%diag) + enddo + + call enable_averages(full_time_step, Time, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) - call disable_averaging(CS%diag) - - enddo + call disable_averaging(CS%diag) end subroutine solo_step_ice_shelf diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 81a4c7e21b..25f6b9f73f 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -768,7 +768,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled ! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) - if (update_ice_vel) then + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) then call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 20a48730f3..1e2076f889 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -22,6 +22,7 @@ module MOM_ice_shelf_initialize public initialize_ice_shelf_boundary_from_file public initialize_ice_C_basal_friction public initialize_ice_AGlen +public initialize_ice_SMB ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units @@ -657,5 +658,51 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) call MOM_read_data(filename,trim(varname), AGlen, G%Domain) endif -end subroutine +end subroutine initialize_ice_AGlen + +!> Initialize ice surface mass balance field that is held constant over time +subroutine initialize_ice_SMB(SMB, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: SMB !< Ice surface mass balance parameter, often in [kg m-2 s-1] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + real :: SMB_val ! Constant ice surface mass balance parameter, often in [kg m-2 s-1] + character(len=40) :: mdl = "initialize_ice_SMB" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, SMB_file + + call get_param(PF, mdl, "ICE_SMB_CONFIG", config, & + "This specifies how the initial ice surface mass balance parameter is specified. "//& + "Valid values are: CONSTANT and FILE.", & + default="CONSTANT") + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "SMB", SMB_val, & + "Surface mass balance.", units="kg m-2 s-1", default=0.0) + + SMB(:,:) = SMB_val + + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading SMB parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "ICE_SMB_FILE", SMB_file, & + "The file from which the ice surface mass balance is read.", & + default="ice_SMB.nc") + filename = trim(inputdir)//trim(SMB_file) + call log_param(PF, mdl, "INPUTDIR/ICE_SMB_FILE", filename) + call get_param(PF, mdl, "ICE_SMB_VARNAME", varname, & + "The variable to use as surface mass balance.", & + default="SMB") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_SMV_from_file: Unable to open "//trim(filename)) + call MOM_read_data(filename,trim(varname), SMB, G%Domain) + + endif +end subroutine initialize_ice_SMB end module MOM_ice_shelf_initialize From c9fc30d61b412bcfb07adddefe6d9632e75f6101 Mon Sep 17 00:00:00 2001 From: alex-huth Date: Wed, 23 Aug 2023 18:29:45 -0400 Subject: [PATCH 122/146] ice shelf dHdt and optimization -fixed a bug in change_thickness_using_precip (was missing a division by ice density) -optimized ice shelf pass_var calls with optional complete arguments -corrected the grid area to multiply with ice shelf driving stress before its post_data call -changed some order of operations by adding parentheses, with the hope that it would improve symmetry of the ice shelf solution during MISMIP+. There was no effect, but this version of the code was used for MISMIP+ and MISOMIP. --- src/ice_shelf/MOM_ice_shelf.F90 | 24 ++-- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 142 +++++++++++------------ 2 files changed, 83 insertions(+), 83 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 7176e3ccdf..89b868f0bf 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -858,9 +858,9 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic endif enddo ; enddo - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) call pass_var(ISS%mass_shelf, G%domain) end subroutine change_thickness_using_melt @@ -1753,10 +1753,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, id_clock_pass = cpu_clock_id(' Ice shelf halo updates', grain=CLOCK_ROUTINE) call cpu_clock_begin(id_clock_pass) - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%mass_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) call pass_var(G%bathyT, G%domain) call cpu_clock_end(id_clock_pass) @@ -2032,7 +2032,7 @@ subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - if (-fluxes%shelf_sfc_mass_flux(i,j) * time_step < ISS%h_shelf(i,j)) then + if (-fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice < ISS%h_shelf(i,j)) then ISS%h_shelf(i,j) = ISS%h_shelf(i,j) + fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice else ! the ice is about to ablate, so set thickness, area, and mask to zero @@ -2101,10 +2101,10 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) CS%min_thickness_simple_calve, halo=0) endif - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) - call pass_var(ISS%mass_shelf, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.true.) end subroutine update_shelf_mass diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 25f6b9f73f..8a40d74b4e 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -21,7 +21,7 @@ module MOM_ice_shelf_dynamics use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state -use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_coms, only : reproducing_sum, max_across_PEs, min_across_PEs use MOM_checksums, only : hchksum, qchksum use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_channel,initialize_ice_flow_from_file use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file,initialize_ice_C_basal_friction @@ -551,20 +551,20 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo endif - call pass_var(CS%OD_av,G%domain) - call pass_var(CS%ground_frac,G%domain) - call pass_var(CS%ice_visc,G%domain) - call pass_var(CS%basal_traction, G%domain) - call pass_var(CS%AGlen_visc, G%domain) - call pass_var(CS%bed_elev, G%domain) - call pass_var(CS%C_basal_friction, G%domain) - call pass_var(CS%h_bdry_val, G%domain) - call pass_var(CS%thickness_bdry_val, G%domain) + call pass_var(CS%OD_av,G%domain, complete=.false.) + call pass_var(CS%ground_frac,G%domain, complete=.false.) + call pass_var(CS%ice_visc,G%domain, complete=.false.) + call pass_var(CS%basal_traction, G%domain, complete=.false.) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.false.) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.false.) + call pass_var(CS%thickness_bdry_val, G%domain, complete=.true.) if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.true.) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif @@ -597,28 +597,28 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! initialize basal friction coefficients if (new_sim) then call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) - call pass_var(CS%C_basal_friction, G%domain) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) ! initialize ice-stiffness AGlen call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) - call pass_var(CS%AGlen_visc, G%domain) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) !initialize boundary conditions call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) - call pass_var(ISS%hmask, G%domain) - call pass_var(CS%h_bdry_val, G%domain) - call pass_var(CS%thickness_bdry_val, G%domain) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.false.) + call pass_var(CS%thickness_bdry_val, G%domain, complete=.true.) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.false.) !initialize ice flow characteristic (velocities, bed elevation under the grounded part, etc) from file call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf, CS%ground_frac, & G, US, param_file) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var(CS%ground_frac, G%domain) - call pass_var(CS%bed_elev, G%domain) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.true.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.true.) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif ! Register diagnostics. @@ -775,11 +775,11 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) ! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf, CS%t_shelf, CS%diag) if (CS%id_taudx_shelf > 0) then - taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaT(:,:) + taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaBu(:,:) call post_data(CS%id_taudx_shelf, taud_x, CS%diag) endif if (CS%id_taudy_shelf > 0) then - taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaT(:,:) + taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaBu(:,:) call post_data(CS%id_taudy_shelf, taud_y, CS%diag) endif if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) @@ -990,7 +990,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i endif enddo ; enddo - call pass_var(float_cond, G%Domain) + call pass_var(float_cond, G%Domain, complete=.false.) call bilinear_shape_functions_subgrid(Phisub, nsub) @@ -1004,9 +1004,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo ; enddo call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%ice_visc, G%domain, complete=.false.) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain) + call pass_var(CS%basal_traction, G%domain, complete=.true.) if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! This makes sure basal stress is only applied when it is supposed to be @@ -1079,9 +1079,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call MOM_mesg(mesg, 5) call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%ice_visc, G%domain, complete=.false.) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain) + call pass_var(CS%basal_traction, G%domain, complete=.true.) if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! makes sure basal stress is only applied when it is supposed to be @@ -1272,18 +1272,18 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H RHSu(:,:) = taudx(:,:) !- ubd(:,:) RHSv(:,:) = taudy(:,:) !- vbd(:,:) - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE, complete=.false.) call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) - call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE, complete=.false.) call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.) Ru(:,:) = (RHSu(:,:) - Au(:,:)) Rv(:,:) = (RHSv(:,:) - Av(:,:)) @@ -1345,12 +1345,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jscq,jecq ; do i=iscq,iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) - sum_vec_2(I,J) = resid_scale * Du(I,J) * Au(I,J) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Du(I,J) * Au(I,J)) endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Dv(I,J) * Av(I,J) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Dv(I,J) * Av(I,J)) endif enddo ; enddo @@ -1400,12 +1400,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jscq,jecq ; do i=iscq,iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) - sum_vec_2(I,J) = resid_scale * Zu_old(I,J) * Ru_old(I,J) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Zu_old(I,J) * Ru_old(I,J)) endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Zv_old(I,J) * Rv_old(I,J) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Zv_old(I,J) * Rv_old(I,J)) endif enddo ; enddo @@ -1443,9 +1443,9 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H if (cg_halo == 0) then ! pass vectors - call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) - call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE, complete=.true.) cg_halo = 3 endif @@ -2262,15 +2262,15 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, do iq=1,2 ; do jq=1,2 - uq = u_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - u_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & - u_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & - u_shlf(I,J) * xquad(iq) * xquad(jq) + uq = u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + u_shlf(I,J) * (xquad(iq) * xquad(jq)) - vq = v_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - v_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & - v_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & - v_shlf(I,J) * xquad(iq) * xquad(jq) + vq = v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + v_shlf(I,J) * (xquad(iq) * xquad(jq)) ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & @@ -2287,7 +2287,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - vy = v_shlf(I-1,j-1) * Phi(2,2*(jq-1)+iq,i,j) + & + vy = v_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) @@ -2306,9 +2306,9 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) endif enddo ; enddo enddo ; enddo @@ -2600,15 +2600,15 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, do iq=1,2 ; do jq=1,2 - uq = CS%u_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - CS%u_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & - CS%u_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & - CS%u_bdry_val(I,J) * xquad(iq) * xquad(jq) + uq = CS%u_bdry_val(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + CS%u_bdry_val(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + CS%u_bdry_val(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + CS%u_bdry_val(I,J) * (xquad(iq) * xquad(jq)) - vq = CS%v_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - CS%v_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & - CS%v_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & - CS%v_bdry_val(I,J) * xquad(iq) * xquad(jq) + vq = CS%v_bdry_val(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + CS%v_bdry_val(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + CS%v_bdry_val(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + CS%v_bdry_val(I,J) * (xquad(iq) * xquad(jq)) ux = CS%u_bdry_val(I-1,J-1) * Phi(1,2*(jq-1)+iq) + & CS%u_bdry_val(I,J-1) * Phi(3,2*(jq-1)+iq) + & @@ -2643,7 +2643,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, if (float_cond(i,j) == 0) then u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) endif endif @@ -2654,7 +2654,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, if (float_cond(i,j) == 0) then v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) endif endif enddo ; enddo @@ -2916,8 +2916,8 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 enddo ; enddo - call pass_var(CS%ground_frac, G%domain) - call pass_var(CS%OD_av, G%domain) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%OD_av, G%domain, complete=.true.) endif end subroutine update_OD_ffrac @@ -2989,8 +2989,8 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) - c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) - d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) + c = -X(1)*(1-xquad(qpoint)) - X(2)*xquad(qpoint) + X(3)*(1-xquad(qpoint)) + X(4)*xquad(qpoint) ! d(x)/d(y*) + d = -Y(1)*(1-xquad(qpoint)) - Y(2)*xquad(qpoint) + Y(3)*(1-xquad(qpoint)) + Y(4)*xquad(qpoint) ! d(y)/d(y*) do node=1,4 @@ -3480,8 +3480,8 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) endif enddo ; enddo - call pass_var(CS%t_shelf, G%domain) - call pass_var(CS%tmask, G%domain) + call pass_var(CS%t_shelf, G%domain, complete=.false.) + call pass_var(CS%tmask, G%domain, complete=.true.) if (CS%debug) then call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3, scale=US%C_to_degC) From f514529a8a299b8e84512a10062aa524f0a23478 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Thu, 26 Oct 2023 15:11:12 -0400 Subject: [PATCH 123/146] Ice sheet thickness boundary condition (#474) * allow for assigned ice shelf thickness where hmask==3, but still solve for ice sheet velocity --- src/ice_shelf/MOM_ice_shelf.F90 | 4 +-- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 42 ++++++++++++------------ src/ice_shelf/MOM_ice_shelf_state.F90 | 4 +-- 3 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 89b868f0bf..84858f17bc 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1660,7 +1660,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j)==3)) then ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo @@ -1727,7 +1727,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%rotate_index, CS%turns) ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j) == 3)) then ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8a40d74b4e..ffa065e400 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -703,7 +703,7 @@ function ice_time_step_CFL(CS, ISS, G) min_dt = 5.0e17*G%US%s_to_T ! The starting maximum is roughly the lifetime of the universe. min_vel = (1.0e-12/(365.0*86400.0)) * G%US%m_s_to_L_T - do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0 .or. ISS%hmask(i,j)==3) then dt_local = 2.0*G%areaT(i,j) / & ((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel) + & G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel)) + & @@ -979,7 +979,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i nodefloat = 0 do l=0,1 ; do k=0,1 - if ((ISS%hmask(i,j) == 1) .and. & + if ((ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j)==3) .and. & (rhoi_rhow * H_node(i-1+k,j-1+l) - CS%bed_elev(i,j) <= 0)) then nodefloat = nodefloat + 1 endif @@ -1512,7 +1512,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after do j=jsh,jeh ; do I=ish-1,ieh if (CS%u_face_mask(I,j) == 4.) then ! The flux itself is a specified boundary condition. uh_ice(I,j) = time_step * G%dyCu(I,j) * CS%u_flux_bdry_val(I,j) - elseif ((hmask(i,j) == 1) .or. (hmask(i+1,j) == 1)) then + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. @@ -1591,8 +1591,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after do J=jsh-1,jeh ; do i=ish,ieh if (CS%v_face_mask(i,J) == 4.) then ! The flux itself is a specified boundary condition. vh_ice(i,J) = time_step * G%dxCv(i,J) * CS%v_flux_bdry_val(i,J) - elseif ((hmask(i,j) == 1) .or. (hmask(i,j+1) == 1)) then - + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. @@ -1760,7 +1759,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux if ((partial_vol / G%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow - ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j).ne.3) ISS%hmask(i,j) = 1 ISS%h_shelf(i,j) = h_reference ISS%area_shelf_h(i,j) = G%areaT(i,j) elseif ((partial_vol / G%areaT(i,j)) < h_reference) then @@ -1770,7 +1769,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) ISS%h_shelf(i,j) = h_reference else - ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j).ne.3) ISS%hmask(i,j) = 1 ISS%area_shelf_h(i,j) = G%areaT(i,j) !h_temp(i,j) = h_reference partial_vol = partial_vol - h_reference * G%areaT(i,j) @@ -1962,30 +1961,31 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) dyh = G%dyT(i,j) Dx=dxh Dy=dyh - if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell + if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then + ! we are inside the global computational bdry, at an ice-filled cell ! calculate sx if ((i+i_off) == gisc) then ! at west computational bdry - if (ISS%hmask(i+1,j) == 1) then + if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then sx = (S(i+1,j)-S(i,j))/dxh else sx = 0 endif elseif ((i+i_off) == giec) then ! at east computational bdry - if (ISS%hmask(i-1,j) == 1) then + if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then sx = (S(i,j)-S(i-1,j))/dxh else sx = 0 endif else ! interior - if (ISS%hmask(i+1,j) == 1) then + if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then cnt = cnt+1 Dx =dxh+ G%dxT(i+1,j) sx = S(i+1,j) else sx = S(i,j) endif - if (ISS%hmask(i-1,j) == 1) then + if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then cnt = cnt+1 Dx =dxh+ G%dxT(i-1,j) sx = sx - S(i-1,j) @@ -2003,26 +2003,26 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! calculate sy, similarly if ((j+j_off) == gjsc) then ! at south computational bdry - if (ISS%hmask(i,j+1) == 1) then + if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then sy = (S(i,j+1)-S(i,j))/dyh else sy = 0 endif elseif ((j+j_off) == gjec) then ! at north computational bdry - if (ISS%hmask(i,j-1) == 1) then + if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then sy = (S(i,j)-S(i,j-1))/dyh else sy = 0 endif else ! interior - if (ISS%hmask(i,j+1) == 1) then + if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then cnt = cnt+1 Dy =dyh+ G%dyT(i,j+1) sy = S(i,j+1) else sy = S(i,j) endif - if (ISS%hmask(i,j-1) == 1) then + if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then cnt = cnt+1 sy = sy - S(i,j-1) Dy =dyh+ G%dyT(i,j-1) @@ -2258,7 +2258,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, Ee=1.0 - do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1) then + do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then do iq=1,2 ; do jq=1,2 @@ -2426,7 +2426,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, Ee=1.0 - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then call bilinear_shape_fn_grid(G, i, j, Phi) @@ -2584,7 +2584,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, Ee=1.0 - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then ! process this cell if any corners have umask set to non-dirichlet bdry. @@ -3221,7 +3221,7 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face endif do j=js,G%jed; do i=is,G%ied - if (hmask(i,j) == 1) then + if (hmask(i,j) == 1 .or. hmask(i,j)==3) then umask(I-1:I,J-1:J)=1 vmask(I-1:I,J-1:J)=1 endif @@ -3362,7 +3362,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) num_h = 0 do k=0,1 do l=0,1 - if (hmask(i+k,j+l) == 1.0) then + if (hmask(i+k,j+l) == 1.0 .or. hmask(i+k,j+l) == 3.0) then summ = summ + h_shelf(i+k,j+l) num_h = num_h + 1 endif diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 32413ad2d8..8b66f35f48 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -31,8 +31,8 @@ module MOM_ice_shelf_state !! ice-covered cells are treated the same, this may change) !! 2: partially covered, do not solve for velocity !! 0: no ice in cell. - !! 3: bdry condition on thickness set - not in computational domain - !! -2 : default (out of computational boundary, and) not = 3 + !! 3: bdry condition on thickness set + !! -2 : default (out of computational boundary) !! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED !! otherwise the wrong nodes will be included in velocity calcs. From 503a9f4c5f585e258a3d5810cad0b4af073c4fb8 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Fri, 27 Oct 2023 06:59:36 -0400 Subject: [PATCH 124/146] ice shelf front advection: When determining a reference thickness for a partially-filled cell, add the reference thickness contribution from a neighboring filled cell proportionate to its flux into the partially-filled cell. This is more accurate than simply taking the average thickness of all neighboring filled cells. Also fixed incorrect bounds. (#475) --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index ffa065e400..2965f6eac4 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1723,14 +1723,14 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do j=jsc-1,jec+1 - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then + if (((j+j_off) <= G%domain%njglobal) .AND. & + ((j+j_off) >= 1)) then do i=isc-1,iec+1 - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then - ! first get reference thickness by averaging over cells that are fluxing into this cell + if (((i+i_off) <= G%domain%niglobal) .AND. & + ((i+i_off) >= 1)) then + ! first get reference thickness by averaging over cells that are fluxing into this cell n_flux = 0 h_reference = 0.0 tot_flux = 0.0 @@ -1738,7 +1738,8 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do k=1,2 if (flux_enter(i,j,k) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) + h_reference = h_reference + flux_enter(i,j,k) * ISS%h_shelf(i+2*k-3,j) + !h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) tot_flux = tot_flux + flux_enter(i,j,k) flux_enter(i,j,k) = 0.0 endif @@ -1747,7 +1748,8 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do k=1,2 if (flux_enter(i,j,k+2) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) + h_reference = h_reference + flux_enter(i,j,k+2) * ISS%h_shelf(i,j+2*k-3) + !h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) tot_flux = tot_flux + flux_enter(i,j,k+2) flux_enter(i,j,k+2) = 0.0 endif @@ -1755,7 +1757,8 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) if (n_flux > 0) then dxdyh = G%areaT(i,j) - h_reference = h_reference / real(n_flux) + h_reference = h_reference / tot_flux + !h_reference = h_reference / real(n_flux) partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux if ((partial_vol / G%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow From ddb88f8c2fb36ce282cfdb34739a1c37ed369abd Mon Sep 17 00:00:00 2001 From: Cory Spencer Jones Date: Mon, 16 Oct 2023 11:33:26 -0500 Subject: [PATCH 125/146] +Add timestamp and directory to particles restart The directory, time and timestamp variables are needed by the particle code in order to write better restart files. I have changed the particles_save_restart interface to add these variables. I have also removed the option to pass temperature and salinity to particles_save_restart, because these variables are not useful for restart. --- config_src/external/drifters/MOM_particles.F90 | 7 ++++--- src/core/MOM.F90 | 3 +-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index b86c720b75..95470e6510 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -47,12 +47,13 @@ end subroutine particles_run !>Save particle locations (and sometimes other vars) to restart file -subroutine particles_save_restart(parts, h, temp, salt) +subroutine particles_save_restart(parts, h, directory, time, time_stamped) ! Arguments type(particles), pointer :: parts !< Container for all types and memory real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] - real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature [C ~> degC] - real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity [S ~> ppt] + character(len=*), intent(in) :: directory !< The directory where the restart files are to be written + type(time_type), intent(in) :: time !< The current model time + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp to the restart file names end subroutine particles_save_restart diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 7ff553b362..64e96bdf10 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -4022,8 +4022,7 @@ subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & time_stamped=time_stamped, filename=filename, GV=GV, & num_rest_files=num_rest_files, write_IC=write_IC) - ! TODO: Update particles to use Time and directories - if (CS%use_particles) call particles_save_restart(CS%particles, CS%h) + if (CS%use_particles) call particles_save_restart(CS%particles, CS%h, directory, time, time_stamped) end subroutine save_MOM_restart From 615e57f854db8be8c75a9edba6bb05e3f04a6eb7 Mon Sep 17 00:00:00 2001 From: raphael dussin Date: Sat, 28 Oct 2023 15:09:45 -0400 Subject: [PATCH 126/146] extension to the internal tides module (#481) the module in now able to read in tidal velocities for different tidal harmonics and distribute the energy and distribute TKE input over the different vertical modes. This involves upsizing dimensions of several arrays and mofiying some API. internal_tide_input_CS is promoted to public to facilitate the passing of energy input to MOM_internal_tides --- .../lateral/MOM_internal_tides.F90 | 184 ++++++++++++++---- .../vertical/MOM_diabatic_driver.F90 | 5 +- .../vertical/MOM_internal_tide_input.F90 | 127 ++++++++---- 3 files changed, 240 insertions(+), 76 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 172d2459d5..a8b0d3f813 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -16,11 +16,13 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_int_tide_input, only: int_tide_input_CS, get_input_TKE, get_barotropic_tidal_vel use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info use MOM_io, only : set_axis_info, get_axis_info use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_restart, only : lock_check, restart_registry_lock use MOM_spatial_means, only : global_area_integral +use MOM_string_functions, only: extract_real use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs @@ -54,6 +56,9 @@ module MOM_internal_tides !! the default is false; it is always true with aggress_adjust. logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. + real, allocatable, dimension(:,:) :: fraction_tidal_input + !< how the energy from one tidal component is distributed + !! over the various vertical modes, 2d in frequency and mode [nondim] real, allocatable, dimension(:,:) :: refl_angle !< local coastline/ridge/shelf angles read from file [rad] ! (could be in G control structure) @@ -161,7 +166,7 @@ module MOM_internal_tides ! Diag handles relevant to all modes, frequencies, and angles integer :: id_cg1 = -1 ! diagnostic handle for mode-1 speed integer, allocatable, dimension(:) :: id_cn ! diagnostic handle for all mode speeds - integer :: id_tot_En = -1, id_TKE_itidal_input = -1, id_itide_drag = -1 + integer :: id_tot_En = -1 integer :: id_refl_pref = -1, id_refl_ang = -1, id_land_mask = -1 integer :: id_trans = -1, id_residual = -1 integer :: id_dx_Cv = -1, id_dy_Cu = -1 @@ -172,7 +177,12 @@ module MOM_internal_tides integer, allocatable, dimension(:,:) :: & id_En_mode, & id_itidal_loss_mode, & + id_leak_loss_mode, & + id_quad_loss_mode, & + id_Froude_loss_mode, & + id_residual_loss_mode, & id_allprocesses_loss_mode, & + id_itide_drag, & id_Ub_mode, & id_cp_mode ! Diag handles considering: all modes, frequencies, and angles @@ -180,6 +190,7 @@ module MOM_internal_tides id_En_ang_mode, & id_itidal_loss_ang_mode integer, allocatable, dimension(:) :: & + id_TKE_itidal_input, & id_Ustruct_mode, & id_Wstruct_mode, & id_int_w2_mode, & @@ -200,8 +211,7 @@ module MOM_internal_tides !> Calls subroutines in this file that are needed to refract, propagate, !! and dissipate energy density of the internal tide. -subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, dt, & - G, GV, US, CS) +subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_CSp, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -209,10 +219,6 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Pointer to thermodynamic variables !! (needed for wave structure). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: TKE_itidal_input !< The energy input to the - !! internal waves [R Z3 T-3 ~> W m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read - !! from file [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. !! In some cases the input values are used, but in !! others this is set along with the wave speeds. @@ -220,9 +226,14 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, !! reference density [R ~> kg m-3]. real, intent(in) :: dt !< Length of time over which to advance !! the internal tides [T ~> s]. + type(int_tide_input_CS), intent(in) :: inttide_input_CSp !< Internal tide input control structure type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure ! Local variables + real, dimension(SZI_(G),SZJ_(G),CS%nFreq) :: & + TKE_itidal_input, & !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),2) :: & test ! A test unit vector used to determine grid rotation in halos [nondim] real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & @@ -231,15 +242,22 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & + drag_scale ! bottom drag scale [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G)) :: & + tot_vel_btTide2, & tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] - drag_scale, & ! bottom drag scale [T-1 ~> s-1] itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [R Z3 T-3 ~> W m-2] + leak_loss_mode, & + quad_loss_mode, & + Froude_loss_mode, & + residual_loss_mode, & allprocesses_loss_mode ! Total energy loss rates for a given mode and frequency (summed over ! all angles) [R Z3 T-3 ~> W m-2] + real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] @@ -273,7 +291,10 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T ! initialize local arrays - drag_scale(:,:) = 0. + TKE_itidal_input(:,:,:) = 0. + vel_btTide(:,:,:) = 0. + tot_vel_btTide2(:,:) = 0. + drag_scale(:,:,:,:) = 0. Ub(:,:,:,:) = 0. Umax(:,:,:,:) = 0. @@ -329,24 +350,27 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, !enddo ; enddo ; enddo ! Add the forcing.*************************************************************** + + call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + if (CS%energized_angle <= 0) then - frac_per_sector = 1.0 / real(CS%nAngle * CS%nMode * CS%nFreq) + frac_per_sector = 1.0 / real(CS%nAngle) do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - TKE_itidal_input(i,j) + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) enddo ; enddo ; enddo ; enddo ; enddo elseif (CS%energized_angle <= CS%nAngle) then - frac_per_sector = 1.0 / real(CS%nMode * CS%nFreq) + frac_per_sector = 1.0 a = CS%energized_angle do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - TKE_itidal_input(i,j) + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) enddo ; enddo ; enddo ; enddo else call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& @@ -397,6 +421,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Propagate the waves. do m=1,CS%nMode ; do fr=1,CS%Nfreq + ! initialize residual loss, will be computed in propagate CS%TKE_residual_loss(:,:,:,fr,m) = 0. call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & @@ -479,29 +504,37 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then - do j=js,je ; do i=is,ie ; htot(i,j) = 0.0 ; enddo ; enddo - do k=1,GV%ke ; do j=js,je ; do i=is,ie + do j=jsd,jed ; do i=isd,ied ; htot(i,j) = 0.0 ; enddo ; enddo + + call get_barotropic_tidal_vel(G, vel_btTide, CS%nFreq, inttide_input_CSp) + + do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied + tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + vel_btTide(i,j,fr)**2 + enddo ; enddo ; enddo + + do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo if (GV%Boussinesq) then ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. - do j=js,je ; do i=is,ie + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) - drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & - tot_En(i,j) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here - enddo ; enddo + drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & + tot_En_mode(i,j,fr,m) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here + enddo ; enddo ; enddo ; enddo else - do j=js,je ; do i=is,ie + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) - drag_scale(i,j) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & - sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + tot_En(i,j) * I_mass)) - enddo ; enddo + drag_scale(i,j,fr,m) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & + sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & + tot_En_mode(i,j,fr,m) * I_mass)) + enddo ; enddo ; enddo ; enddo endif do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) - CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j) ! loss rate - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j)) ! implicit update + CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j,fr,m) ! loss rate + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j,fr,m)) ! implicit update enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later @@ -685,9 +718,14 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Output two-dimensional diagnostics if (CS%id_tot_En > 0) call post_data(CS%id_tot_En, tot_En, CS%diag) - if (CS%id_itide_drag > 0) call post_data(CS%id_itide_drag, drag_scale, CS%diag) - if (CS%id_TKE_itidal_input > 0) call post_data(CS%id_TKE_itidal_input, & - TKE_itidal_input, CS%diag) + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_input(fr) > 0) call post_data(CS%id_TKE_itidal_input(fr), & + TKE_itidal_input(:,:,fr), CS%diag) + enddo + + do m=1,CS%nMode ; do fr=1,CS%nFreq + if (CS%id_itide_drag(fr,m) > 0) call post_data(CS%id_itide_drag(fr,m), drag_scale(:,:,fr,m), CS%diag) + enddo ; enddo ! Output 2-D energy density (summed over angles) for each frequency and mode do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then @@ -780,15 +818,27 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, do m=1,CS%nMode ; do fr=1,CS%Nfreq if (CS%id_itidal_loss_mode(fr,m) > 0 .or. CS%id_allprocesses_loss_mode(fr,m) > 0) then itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) + leak_loss_mode(:,:) = 0.0 + quad_loss_mode(:,:) = 0.0 + Froude_loss_mode(:,:) = 0.0 + residual_loss_mode(:,:) = 0.0 allprocesses_loss_mode(:,:) = 0.0 ! all processes summed together do a=1,CS%nAngle ; do j=js,je ; do i=is,ie itidal_loss_mode(i,j) = itidal_loss_mode(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) + leak_loss_mode(i,j) = leak_loss_mode(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) + quad_loss_mode(i,j) = quad_loss_mode(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) + Froude_loss_mode(i,j) = Froude_loss_mode(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) + residual_loss_mode(i,j) = residual_loss_mode(i,j) + CS%TKE_residual_loss(i,j,a,fr,m) allprocesses_loss_mode(i,j) = allprocesses_loss_mode(i,j) + & ((((CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m)) + & CS%TKE_itidal_loss(i,j,a,fr,m)) + CS%TKE_Froude_loss(i,j,a,fr,m)) + & CS%TKE_residual_loss(i,j,a,fr,m)) enddo ; enddo ; enddo call post_data(CS%id_itidal_loss_mode(fr,m), itidal_loss_mode, CS%diag) + call post_data(CS%id_leak_loss_mode(fr,m), leak_loss_mode, CS%diag) + call post_data(CS%id_quad_loss_mode(fr,m), quad_loss_mode, CS%diag) + call post_data(CS%id_Froude_loss_mode(fr,m), Froude_loss_mode, CS%diag) + call post_data(CS%id_residual_loss_mode(fr,m), residual_loss_mode, CS%diag) call post_data(CS%id_allprocesses_loss_mode(fr,m), allprocesses_loss_mode, CS%diag) endif ; enddo ; enddo @@ -2501,6 +2551,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) real :: RMS_roughness_frac ! The maximum RMS topographic roughness as a fraction of the ! nominal ocean depth, or a negative value for no limit [nondim] real :: period_1 ! The period of the gravest modeled mode [T ~> s] + real :: period ! A tidal period read from namelist [T ~> s] integer :: num_angle, num_freq, num_mode, m, fr integer :: isd, ied, jsd, jed, a, id_ang, i, j, nz type(axes_grp) :: axes_ang @@ -2516,6 +2567,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=200) :: h2_file character(len=80) :: rough_var ! Input file variable names + character(len=240), dimension(:), allocatable :: energy_fractions + character(len=240) :: periods + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed nz = GV%ke @@ -2539,17 +2593,29 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (.not.((num_freq > 0) .and. (num_angle > 0) .and. (num_mode > 0))) return CS%nFreq = num_freq ; CS%nAngle = num_angle ; CS%nMode = num_mode + allocate(energy_fractions(num_freq)) + allocate(CS%fraction_tidal_input(num_freq,num_mode)) + + call read_param(param_file, "ENERGY_FRACTION_PER_MODE", energy_fractions) + + do fr=1,num_freq ; do m=1,num_mode + CS%fraction_tidal_input(fr,m) = extract_real(energy_fractions(fr), " ,", m, 0.) + enddo ; enddo + ! Allocate phase speed array allocate(CS%cp(isd:ied, jsd:jed, num_freq, num_mode), source=0.0) ! Allocate and populate frequency array (each a multiple of first for now) allocate(CS%frequency(num_freq)) - call get_param(param_file, mdl, "FIRST_MODE_PERIOD", period_1, & - "The period of the first mode for internal tides", default=44567., & - units="s", scale=US%s_to_T) + + + ! The periods of the tidal constituents for internal tides raytracing + call read_param(param_file, "TIDAL_PERIODS", periods) do fr=1,num_freq - CS%frequency(fr) = (8.0*atan(1.0) * (real(fr)) / period_1) ! ADDED BDM + period = extract_real(periods, " ,", fr, 0.) + if (period == 0.) call MOM_error(FATAL, "MOM_internal_tides: invalid tidal period") + CS%frequency(fr) = 8.0*atan(1.0)/period enddo ! Read all relevant parameters and write them to the model log. @@ -2858,14 +2924,18 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & Time, 'Internal tide total energy density', & 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) - ! Register 2-D drag scale used for quadratic bottom drag - CS%id_itide_drag = register_diag_field('ocean_model', 'ITide_drag', diag%axesT1, & - Time, 'Interior and bottom drag internal tide decay timescale', 's-1', conversion=US%s_to_T) - !Register 2-D energy input into internal tides - CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & - Time, 'Conversion from barotropic to baroclinic tide, '//& - 'a fraction of which goes into rays', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + + allocate(CS%id_itide_drag(CS%nFreq, CS%nMode), source=-1) + allocate(CS%id_TKE_itidal_input(CS%nFreq), source=-1) + do fr=1,CS%nFreq + ! Register 2-D energy input into internal tides for each frequency + write(var_name, '("TKE_itidal_input_freq",i1)') fr + write(var_descript, '("a fraction of which goes into rays in frequency ",i1)') fr + + CS%id_TKE_itidal_input(fr) = register_diag_field('ocean_model', var_name, diag%axesT1, & + Time, 'Conversion from barotropic to baroclinic tide, '//& + var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + enddo ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', & @@ -2889,6 +2959,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%id_En_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_itidal_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_leak_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_quad_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_Froude_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_residual_loss_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_allprocesses_loss_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_itidal_loss_ang_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_Ub_mode(CS%nFreq,CS%nMode), source=-1) @@ -2929,6 +3003,30 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Leakage loss + write(var_name, '("Itide_leak_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy loss due to leakage from frequency ",i1," mode ",i1)') fr, m + CS%id_leak_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Quad loss + write(var_name, '("Itide_quad_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy quad loss from frequency ",i1," mode ",i1)') fr, m + CS%id_quad_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Froude loss + write(var_name, '("Itide_froude_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy Froude loss from frequency ",i1," mode ",i1)') fr, m + CS%id_froude_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! residual losses + write(var_name, '("Itide_residual_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy residual loss from frequency ",i1," mode ",i1)') fr, m + CS%id_residual_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! all loss processes write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m @@ -2958,6 +3056,12 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) diag%axesT1, Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Register 2-D drag scale used for quadratic bottom drag for each frequency and mode + write(var_name, '("ITide_drag_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Interior and bottom drag int tide decay timescale in frequency ",i1, " mode ",i1)') fr, m + + CS%id_itide_drag(fr,m) = register_diag_field('ocean_model', var_name, diag%axesT1, Time, & + 's-1', conversion=US%s_to_T) enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 5b89c8c726..097628c032 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -391,8 +391,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & CS%int_tide_input_CSp) - call propagate_int_tide(h, tv, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & - CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, G, GV, US, CS%int_tide_CSp) + call propagate_int_tide(h, tv, CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, & + G, GV, US, CS%int_tide_input_CSp, CS%int_tide_CSp) + if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 3da21b48fb..7280106125 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -11,11 +11,13 @@ module MOM_int_tide_input use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : read_param use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, MOM_read_data use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_string_functions, only : extractWord use MOM_time_manager, only : time_type, set_time, operator(+), operator(<=) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d @@ -27,6 +29,7 @@ module MOM_int_tide_input #include public set_int_tide_input, int_tide_input_init, int_tide_input_end +public get_input_TKE, get_barotropic_tidal_vel ! 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 @@ -44,9 +47,13 @@ module MOM_int_tide_input real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - real, allocatable, dimension(:,:) :: TKE_itidal_coef + real, allocatable, dimension(:,:,:) :: TKE_itidal_coef !< The time-invariant field that enters the TKE_itidal input calculation noting that the !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. + real, allocatable, dimension(:,:,:) :: & + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. + tideamp !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. + character(len=200) :: inputdir !< The directory for input files. logical :: int_tide_source_test !< If true, apply an arbitrary generation site @@ -59,19 +66,19 @@ module MOM_int_tide_input integer :: int_tide_source_i !< I Location of generation site integer :: int_tide_source_j !< J Location of generation site logical :: int_tide_use_glob_ij !< Use global indices for generation site + integer :: nFreq = 0 !< The number of internal tide frequency bands !>@{ Diagnostic IDs - integer :: id_TKE_itidal_itide = -1, id_Nb = -1, id_N2_bot = -1 + integer, allocatable, dimension(:) :: id_TKE_itidal_itide + integer :: id_Nb = -1, id_N2_bot = -1 !>@} end type int_tide_input_CS !> This type is used to exchange fields related to the internal tides. type, public :: int_tide_input_type real, allocatable, dimension(:,:) :: & - TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. h2, & !< The squared topographic roughness height [Z2 ~> m2]. - tideamp, & !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. Nb, & !< The bottom stratification [T-1 ~> s-1]. Rho_bot !< The bottom density or the Boussinesq reference density [R ~> kg m-3]. end type int_tide_input_type @@ -110,6 +117,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global + integer :: fr is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -133,52 +141,55 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) if (GV%Boussinesq .or. GV%semi_Boussinesq) then !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) - itide%TKE_itidal_input(i,j) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) - enddo ; enddo + CS%TKE_itidal_input(i,j,fr) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), CS%TKE_itide_max) + enddo ; enddo ; enddo else !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) - itide%TKE_itidal_input(i,j) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), & + CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & CS%TKE_itide_max) - enddo ; enddo + enddo ; enddo ; enddo endif if (CS%int_tide_source_test) then - itide%TKE_itidal_input(:,:) = 0.0 + CS%TKE_itidal_input(:,:,:) = 0.0 if (time_end <= CS%time_max_source) then if (CS%int_tide_use_glob_ij) then - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie i_global = i + G%idg_offset j_global = j + G%jdg_offset if ((i_global == CS%int_tide_source_i) .and. (j_global == CS%int_tide_source_j)) then - itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 endif - enddo ; enddo + enddo ; enddo ; enddo else - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie ! Input an arbitrary energy point source.id_ if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then - itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 endif - enddo ; enddo + enddo ; enddo ; enddo endif endif endif if (CS%debug) then call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) - call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & + call hchksum(CS%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & scale=US%RZ3_T3_to_W_m2) endif call enable_averages(dt, time_end, CS%diag) - if (CS%id_TKE_itidal_itide > 0) call post_data(CS%id_TKE_itidal_itide, itide%TKE_itidal_input, CS%diag) + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_itide(fr) > 0) call post_data(CS%id_TKE_itidal_itide(fr), & + CS%TKE_itidal_input(isd:ied,jsd:jed,fr), CS%diag) + enddo if (CS%id_Nb > 0) call post_data(CS%id_Nb, itide%Nb, CS%diag) if (CS%id_N2_bot > 0 ) call post_data(CS%id_N2_bot, N2_bot, CS%diag) @@ -319,6 +330,38 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bo end subroutine find_N2_bottom +!> Returns TKE_itidal_input +subroutine get_input_TKE(G, TKE_itidal_input, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: TKE_itidal_input !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + integer, intent(in) :: nFreq !< number of frequencies + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + TKE_itidal_input(i,j,fr) = CS%TKE_itidal_input(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_input_TKE + +!> Returns barotropic tidal velocities +subroutine get_barotropic_tidal_vel(G, vel_btTide, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + integer, intent(in) :: nFreq !< number of frequencies + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + vel_btTide(i,j,fr) = CS%tideamp(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_barotropic_tidal_vel + !> Initializes the data related to the internal tide input module subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) type(time_type), intent(in) :: Time !< The current model time @@ -337,6 +380,9 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) character(len=40) :: mdl = "MOM_int_tide_input" ! This module's name. character(len=200) :: filename, tideamp_file, h2_file ! Input file names or paths character(len=80) :: tideamp_var, rough_var ! Input file variable names + character(len=80) :: var_name + character(len=200) :: var_descript + character(len=200) :: tidefile_varnames real :: mask_itidal ! A multiplicative land mask, 0 or 1 [nondim] real :: max_frac_rough ! The fraction relating the maximum topographic roughness @@ -349,6 +395,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) integer :: tlen_days !< Time interval from start for adding wave source !! for testing internal tides (BDM) integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + integer :: num_freq, fr if (associated(CS)) then call MOM_error(WARNING, "int_tide_input_init called with an associated "// & @@ -390,12 +437,15 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call read_param(param_file, "INTERNAL_TIDE_FREQS", num_freq) + CS%nFreq= num_freq + allocate(itide%Nb(isd:ied,jsd:jed), source=0.0) allocate(itide%Rho_bot(isd:ied,jsd:jed), source=0.0) allocate(itide%h2(isd:ied,jsd:jed), source=0.0) - allocate(itide%TKE_itidal_input(isd:ied,jsd:jed), source=0.0) - allocate(itide%tideamp(isd:ied,jsd:jed), source=utide) - allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed), source=0.0) + allocate(CS%TKE_itidal_input(isd:ied,jsd:jed,num_freq), source=0.0) + allocate(CS%tideamp(isd:ied,jsd:jed,num_freq), source=utide) + allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed, num_freq), source=0.0) call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& @@ -419,10 +469,13 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & - "The name of the tidal amplitude variable in the input file.", & - default="tideamp") - call MOM_read_data(filename, tideamp_var, itide%tideamp, G%domain, scale=US%m_s_to_L_T) + + call read_param(param_file, "INTTIDE_AMP_VARNAMES", tidefile_varnames) + do fr=1,num_freq + tideamp_var = extractWord(tidefile_varnames,fr) + call MOM_read_data(filename, tideamp_var, CS%tideamp(:,:,fr), G%domain, scale=US%m_s_to_L_T) + enddo + endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -475,25 +528,31 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) endif endif - do j=js,je ; do i=is,ie + do fr=1,num_freq ; do j=js,je ; do i=is,ie mask_itidal = 1.0 if (G%bathyT(i,j) + G%Z_ref < min_zbot_itides) mask_itidal = 0.0 - itide%tideamp(i,j) = itide%tideamp(i,j) * mask_itidal * G%mask2dT(i,j) + CS%tideamp(i,j,fr) = CS%tideamp(i,j,fr) * mask_itidal * G%mask2dT(i,j) ! Restrict rms topo to a fraction (often 10 percent) of the column depth. if (max_frac_rough >= 0.0) & itide%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, itide%h2(i,j)) ! Compute the fixed part of internal tidal forcing; units are [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] here. - CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & - kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 - enddo ; enddo + CS%TKE_itidal_coef(i,j,fr) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & + kappa_itides * itide%h2(i,j) * CS%tideamp(i,j,fr)**2 + enddo ; enddo ; enddo - CS%id_TKE_itidal_itide = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & - 'Internal Tide Driven Turbulent Kinetic Energy', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + allocate( CS%id_TKE_itidal_itide(num_freq), source=-1) + + do fr=1,num_freq + write(var_name, '("TKE_itidal_itide_freq",i1)') fr + write(var_descript, '("Internal Tide Driven Turbulent Kinetic Energy in frequency ",i1)') fr + + CS%id_TKE_itidal_itide(fr) = register_diag_field('ocean_model',var_name,diag%axesT1,Time, & + var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + enddo CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) From d210cc6cdfd03150306c8ba41612e3380d66c281 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 16 Aug 2023 17:11:35 -0400 Subject: [PATCH 127/146] +Remove build_grid_arbitrary Removed the unused (and unusable) routine build_grid_arbitrary. This routine could not have been used because it had a hard-coded STOP call, and comments in it indicated that it should have been deleted in July, 2013. The run-time parameter setting that would have triggered a call to this routine has been retained for now, but with a fatal error message explaining that this routine has not been implemented. All answers are bitwise identical in any cases that ran before. --- src/ALE/MOM_regridding.F90 | 111 +------------------------------------ 1 file changed, 3 insertions(+), 108 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 1b006dbbd3..8ef0679358 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -855,9 +855,6 @@ subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & case ( REGRIDDING_RHO ) call build_rho_grid( G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) - case ( REGRIDDING_ARBITRARY ) - call build_grid_arbitrary( G, GV, h, nom_depth_H, dzInterface, trickGnuCompiler, CS ) - call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) call build_grid_HyCOM1( G, GV, G%US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, & frac_shelf_h, zScale=Z_to_H ) @@ -868,6 +865,9 @@ subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & call build_grid_adaptive(G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + case ( REGRIDDING_ARBITRARY ) + call MOM_error(FATAL,'MOM_regridding, regridding_main: '//& + 'Regridding mode "ARB" is not implemented.') case default call MOM_error(FATAL,'MOM_regridding, regridding_main: '//& 'Unknown regridding scheme selected!') @@ -1762,111 +1762,6 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) end subroutine adjust_interface_motion -!------------------------------------------------------------------------------ -! Build arbitrary grid -!------------------------------------------------------------------------------ -subroutine build_grid_arbitrary( G, GV, h, nom_depth_H, dzInterface, h_new, CS ) -!------------------------------------------------------------------------------ -! This routine builds a grid based on arbitrary rules -!------------------------------------------------------------------------------ - - ! Arguments - 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 !< Original layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column - !! relative to mean sea level or another locally - !! valid reference height, converted to thickness - !! units [H ~> m or kg m-2] - type(regridding_CS), intent(in) :: CS !< Regridding control structure - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface - !! depth [H ~> m or kg m-2] - real, intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] - - ! Local variables - integer :: i, j, k - integer :: nz - real :: z_inter(SZK_(GV)+1) - real :: total_height - real :: delta_h - real :: max_depth - real :: eta ! local elevation [H ~> m or kg m-2] - real :: local_depth ! The local ocean depth relative to mean sea level in thickness units [H ~> m or kg m-2] - real :: x1, y1, x2, y2 - real :: x, t - - nz = GV%ke - max_depth = G%max_depth*GV%Z_to_H - - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - - ! Local depth - local_depth = nom_depth_H(i,j) - - ! Determine water column height - total_height = 0.0 - do k = 1,nz - total_height = total_height + h(i,j,k) - enddo - - eta = total_height - local_depth - - ! Compute new thicknesses based on stretched water column - delta_h = (max_depth + eta) / nz - - ! Define interfaces - z_inter(1) = eta - do k = 1,nz - z_inter(k+1) = z_inter(k) - delta_h - enddo - - ! Refine grid in the middle - do k = 1,nz+1 - x1 = 0.35; y1 = 0.45; x2 = 0.65; y2 = 0.55 - - x = - ( z_inter(k) - eta ) / max_depth - - if ( x <= x1 ) then - t = y1*x/x1 - elseif ( (x > x1 ) .and. ( x < x2 )) then - t = y1 + (y2-y1) * (x-x1) / (x2-x1) - else - t = y2 + (1.0-y2) * (x-x2) / (1.0-x2) - endif - - z_inter(k) = -t * max_depth + eta - - enddo - - ! Modify interface heights to account for topography - z_inter(nz+1) = - local_depth - - ! Modify interface heights to avoid layers of zero thicknesses - do k = nz,1,-1 - if ( z_inter(k) < (z_inter(k+1) + CS%min_thickness) ) then - z_inter(k) = z_inter(k+1) + CS%min_thickness - endif - enddo - - ! Change in interface position - x = 0. ! Left boundary at x=0 - dzInterface(i,j,1) = 0. - do k = 2,nz - x = x + h(i,j,k) - dzInterface(i,j,k) = z_inter(k) - x - enddo - dzInterface(i,j,nz+1) = 0. - - enddo - enddo - -stop 'OOOOOOPS' ! For some reason the gnu compiler will not let me delete this - ! routine???? - -end subroutine build_grid_arbitrary - - !------------------------------------------------------------------------------ ! Check grid integrity From 467d1dd016317c2bbd51586ef3960383abc87f31 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 16 Aug 2023 17:13:38 -0400 Subject: [PATCH 128/146] +Remove rescale_grid_bathymetry Removed the unused routine rescale_grid_bathymetry. This routine was added in August 2018 as a part of the development of the depth unit conversion and dimensional consistency testing, but it is no longer being called now that this conversion is essentially complete (and it has not been called by the code in several years). For the original commit that first added this code, see github.com/mom-ocean/MOM6/commit/ddc9ed1c33a1b7357b213929118ecaa19ae63f9f. All answers are bitwise identical. --- src/core/MOM.F90 | 2 +- src/core/MOM_grid.F90 | 36 +----------------------------------- 2 files changed, 2 insertions(+), 36 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 64e96bdf10..bb890d2d87 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -89,7 +89,7 @@ module MOM use MOM_forcing_type, only : copy_common_forcing_fields, set_derived_forcing_fields use MOM_forcing_type, only : homogenize_forcing, homogenize_mech_forcing use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end -use MOM_grid, only : set_first_direction, rescale_grid_bathymetry +use MOM_grid, only : set_first_direction use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_hor_index, only : rotate_hor_index use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 2e413e505b..9cbf420b23 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -15,7 +15,7 @@ module MOM_grid #include public MOM_grid_init, MOM_grid_end, set_derived_metrics, set_first_direction -public isPointInCell, hor_index_type, get_global_grid_size, rescale_grid_bathymetry +public isPointInCell, hor_index_type, get_global_grid_size ! 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 @@ -400,40 +400,6 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v end subroutine MOM_grid_init -!> rescale_grid_bathymetry permits a change in the internal units for the bathymetry on the grid, -!! both rescaling the depths and recording the new internal units. -subroutine rescale_grid_bathymetry(G, m_in_new_units) - type(ocean_grid_type), intent(inout) :: G !< The horizontal grid structure - real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth. - !### It appears that this routine is never called. - - ! Local variables - real :: rescale ! A unit rescaling factor [various combinations of units ~> 1] - integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - if (m_in_new_units == 1.0) return - if (m_in_new_units < 0.0) & - call MOM_error(FATAL, "rescale_grid_bathymetry: Negative depth units are not permitted.") - if (m_in_new_units == 0.0) & - call MOM_error(FATAL, "rescale_grid_bathymetry: Zero depth units are not permitted.") - - rescale = 1.0 / m_in_new_units - do j=jsd,jed ; do i=isd,ied - G%bathyT(i,j) = rescale*G%bathyT(i,j) - enddo ; enddo - if (G%bathymetry_at_vel) then ; do j=jsd,jed ; do I=IsdB,IedB - G%Dblock_u(I,j) = rescale*G%Dblock_u(I,j) ; G%Dopen_u(I,j) = rescale*G%Dopen_u(I,j) - enddo ; enddo ; endif - if (G%bathymetry_at_vel) then ; do J=JsdB,JedB ; do i=isd,ied - G%Dblock_v(i,J) = rescale*G%Dblock_v(i,J) ; G%Dopen_v(i,J) = rescale*G%Dopen_v(i,J) - enddo ; enddo ; endif - G%max_depth = rescale*G%max_depth - -end subroutine rescale_grid_bathymetry - !> set_derived_metrics calculates metric terms that are derived from other metrics. subroutine set_derived_metrics(G, US) type(ocean_grid_type), intent(inout) :: G !< The horizontal grid structure From 19f0147067db2d8ec8fb8919bdaa4ee622edd94e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 13 Oct 2023 08:34:37 -0400 Subject: [PATCH 129/146] +Fix dimensional rescaling with HARMONICS_SAL Corrected dimensional rescaling bugs in the spherical harmonics SAL code. An issue with horizontal length scaling was corrected by using G%Rad_Earth_L in place of G%Rad_Earth in spherical_harmonics_init. There are new optional tmp_scale arguments to calc_SAL and spherical_harmonics_forward to allow the rescaling to be undone before calling the reproducing sums. This commit also modifies the call to the reproducing sums in spherical_harmonics_forward so that all real or imaginary components are calculated with a single call, which reduces the cost of the SAL calculation reproducing sums from about 6.7 times the cost with non-reproducing sums to just 5.5 times as much in testing with the tides_025 test case. There is also code added to avoid NaNs arising from a square root operating on a negative argument from a 32-bit integer roll-over when a very large number of harmonics components (more than 1024 x 1024) are unadvisedly being used. While this commit corrects the dimensional scaling when HARMONICS_SAL is true, all answers are bitwise identical when no rescaling is used or when the spherical harmonics SAL is not used. There are new optional arguments to two publicly visible interfaces. --- src/core/MOM_PressureForce_FV.F90 | 6 +-- src/core/MOM_PressureForce_Montgomery.F90 | 4 +- .../lateral/MOM_self_attr_load.F90 | 14 ++++--- .../lateral/MOM_spherical_harmonics.F90 | 42 ++++++++++++------- 4 files changed, 41 insertions(+), 25 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 64df200f31..5fb3ade634 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -319,7 +319,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & - max(-G%bathyT(i,j)-G%Z_ref, 0.0) enddo ; enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq) .or. (.not.CS%tides)) then !$OMP parallel do default(shared) @@ -587,7 +587,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) @@ -618,7 +618,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 3de713c801..6d982bc7e3 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -216,7 +216,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb enddo ; enddo ; enddo endif - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*e_sal(i,j) @@ -481,7 +481,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index 20d239eb53..7f7215c9d8 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -42,19 +42,21 @@ module MOM_self_attr_load !! be changed into bottom pressure anomaly in the future. Note that the SAL calculation applies to all motions !! across the spectrum. Tidal-specific methods that assume periodicity, i.e. iterative and read-in SAL, are !! stored in MOM_tidal_forcing module. -subroutine calc_SAL(eta, eta_sal, G, CS) +subroutine calc_SAL(eta, eta_sal, G, CS, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from !! a time-mean geoid [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The sea surface height anomaly from !! self-attraction and loading [Z ~> m]. type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call to SAL_init. + real, optional, intent(in) :: tmp_scale !< A rescaling factor to temporarily convert eta + !! to MKS units in reproducing sumes [m Z-1 ~> 1] ! Local variables integer :: n, m, l integer :: Isq, Ieq, Jsq, Jeq integer :: i, j - real :: eta_prop + real :: eta_prop ! The scalar constant of proportionality between eta and eta_sal [nondim] call cpu_clock_begin(id_clock_SAL) @@ -69,7 +71,7 @@ subroutine calc_SAL(eta, eta_sal, G, CS) ! use the spherical harmonics method elseif (CS%use_sal_sht) then - call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd) + call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd, tmp_scale=tmp_scale) ! Multiply scaling factors to each mode do m = 0,CS%sal_sht_Nd @@ -119,8 +121,8 @@ subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) real, dimension(:), intent(out) :: Love_Scaling !< Scaling factors for inverse SHT [nondim] ! Local variables - real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames - real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers + real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames [nondim] + real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers [nondim] integer :: n_tot ! Size of the stored Love numbers integer :: n, m, l @@ -163,7 +165,7 @@ subroutine SAL_init(G, US, param_file, CS) logical :: calculate_sal logical :: tides, use_tidal_sal_file - real :: tide_sal_scalar_value + real :: tide_sal_scalar_value ! Scaling SAL factor [nondim] ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 2a72d26a20..26258e6b8e 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -42,7 +42,7 @@ module MOM_spherical_harmonics contains !> Calculates forward spherical harmonics transforms -subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) +subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(sht_CS), intent(inout) :: CS !< Control structure for SHT real, dimension(SZI_(G),SZJ_(G)), & @@ -51,13 +51,20 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) real, intent(out) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) [A] integer, optional, intent(in) :: Nd !< Maximum degree of the spherical harmonics !! overriding ndegree in the CS [nondim] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor to convert + !! var to MKS units during the reproducing + !! sums [a A-1 ~> 1] ! local variables - integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics [nondim] - integer :: Ltot ! Local copy of the number of spherical harmonics [nondim] + integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics + integer :: Ltot ! Local copy of the number of spherical harmonics real, dimension(SZI_(G),SZJ_(G)) :: & pmn, & ! Current associated Legendre polynomials of degree n and order m [nondim] pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nondim] pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nondim] + real :: scale ! A rescaling factor to temporarily convert var to MKS units during the + ! reproducing sums [a A-1 ~> 1] + real :: I_scale ! The inverse of scale [A a-1 ~> 1] + real :: sum_tot ! The total of all components output by the reproducing sum in arbitrary units [a] integer :: i, j, k integer :: is, ie, js, je, isd, ied, jsd, jed integer :: m, n, l @@ -81,12 +88,13 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) do l=1,Ltot ; Snm_Re(l) = 0.0; Snm_Im(l) = 0.0 ; enddo if (CS%reprod_sum) then + scale = 1.0 ; if (present(tmp_scale)) scale = tmp_scale do m=0,Nmax l = order2index(m, Nmax) do j=js,je ; do i=is,ie - CS%Snm_Re_raw(i,j,l) = var(i,j) * CS%Pmm(i,j,m+1) * CS%cos_lonT_wtd(i,j,m+1) - CS%Snm_Im_raw(i,j,l) = var(i,j) * CS%Pmm(i,j,m+1) * CS%sin_lonT_wtd(i,j,m+1) + CS%Snm_Re_raw(i,j,l) = (scale*var(i,j)) * CS%Pmm(i,j,m+1) * CS%cos_lonT_wtd(i,j,m+1) + CS%Snm_Im_raw(i,j,l) = (scale*var(i,j)) * CS%Pmm(i,j,m+1) * CS%sin_lonT_wtd(i,j,m+1) pmnm2(i,j) = 0.0 pmnm1(i,j) = CS%Pmm(i,j,m+1) enddo ; enddo @@ -94,8 +102,8 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) do n = m+1, Nmax ; do j=js,je ; do i=is,ie pmn(i,j) = & CS%a_recur(n+1,m+1) * CS%cos_clatT(i,j) * pmnm1(i,j) - CS%b_recur(n+1,m+1) * pmnm2(i,j) - CS%Snm_Re_raw(i,j,l+n-m) = var(i,j) * pmn(i,j) * CS%cos_lonT_wtd(i,j,m+1) - CS%Snm_Im_raw(i,j,l+n-m) = var(i,j) * pmn(i,j) * CS%sin_lonT_wtd(i,j,m+1) + CS%Snm_Re_raw(i,j,l+n-m) = (scale*var(i,j)) * pmn(i,j) * CS%cos_lonT_wtd(i,j,m+1) + CS%Snm_Im_raw(i,j,l+n-m) = (scale*var(i,j)) * pmn(i,j) * CS%sin_lonT_wtd(i,j,m+1) pmnm2(i,j) = pmnm1(i,j) pmnm1(i,j) = pmn(i,j) enddo ; enddo ; enddo @@ -125,10 +133,15 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) if (id_clock_sht_global_sum>0) call cpu_clock_begin(id_clock_sht_global_sum) if (CS%reprod_sum) then - do l=1,Ltot - Snm_Re(l) = reproducing_sum(CS%Snm_Re_raw(:,:,l)) - Snm_Im(l) = reproducing_sum(CS%Snm_Im_raw(:,:,l)) - enddo + sum_tot = reproducing_sum(CS%Snm_Re_raw(:,:,1:Ltot), sums=Snm_Re(1:Ltot)) + sum_tot = reproducing_sum(CS%Snm_Im_raw(:,:,1:Ltot), sums=Snm_Im(1:Ltot)) + if (scale /= 1.0) then + I_scale = 1.0 / scale + do l=1,Ltot + Snm_Re(l) = I_scale * Snm_Re(l) + Snm_Im(l) = I_scale * Snm_Im(l) + enddo + endif else call sum_across_PEs(Snm_Re, Ltot) call sum_across_PEs(Snm_Im, Ltot) @@ -240,8 +253,9 @@ subroutine spherical_harmonics_init(G, param_file, CS) allocate(CS%a_recur(CS%ndegree+1, CS%ndegree+1)); CS%a_recur(:,:) = 0.0 allocate(CS%b_recur(CS%ndegree+1, CS%ndegree+1)); CS%b_recur(:,:) = 0.0 do m=0,CS%ndegree ; do n=m+1,CS%ndegree + ! These expressione will give NaNs with 32-bit integers for n > 23170, but this is trapped elsewhere. CS%a_recur(n+1,m+1) = sqrt(real((2*n-1) * (2*n+1)) / real((n-m) * (n+m))) - CS%b_recur(n+1,m+1) = sqrt(real((2*n+1) * (n+m-1) * (n-m-1)) / real((n-m) * (n+m) * (2*n-3))) + CS%b_recur(n+1,m+1) = sqrt((real(2*n+1) * real((n+m-1) * (n-m-1))) / (real((n-m) * (n+m)) * real(2*n-3))) enddo ; enddo ! Calculate complex exponential factors @@ -253,8 +267,8 @@ subroutine spherical_harmonics_init(G, param_file, CS) do j=js,je ; do i=is,ie CS%cos_lonT(i,j,m+1) = cos(real(m) * (G%geolonT(i,j)*RADIAN)) CS%sin_lonT(i,j,m+1) = sin(real(m) * (G%geolonT(i,j)*RADIAN)) - CS%cos_lonT_wtd(i,j,m+1) = CS%cos_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth**2 - CS%sin_lonT_wtd(i,j,m+1) = CS%sin_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth**2 + CS%cos_lonT_wtd(i,j,m+1) = CS%cos_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth_L**2 + CS%sin_lonT_wtd(i,j,m+1) = CS%sin_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth_L**2 enddo ; enddo enddo From ffa6af667cdce26376e1fa49dc9806d52116b435 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Oct 2023 17:38:01 -0400 Subject: [PATCH 130/146] Document 31 real variables units Added standard-format unit descriptions for 31 real variables in comments scattered across 14 modules in the core, tracer, and both parameterizations directories. Only comments are changed and all answers are bitwise identical. --- src/core/MOM_barotropic.F90 | 8 ++++---- src/core/MOM_dynamics_split_RK2.F90 | 12 ++++++------ src/core/MOM_forcing_type.F90 | 4 ++-- src/core/MOM_grid.F90 | 16 ++++++++++------ src/core/MOM_interface_heights.F90 | 2 +- .../lateral/MOM_mixed_layer_restrat.F90 | 4 ++-- .../lateral/MOM_thickness_diffuse.F90 | 4 ++-- .../lateral/MOM_tidal_forcing.F90 | 2 +- .../vertical/MOM_energetic_PBL.F90 | 2 +- src/parameterizations/vertical/MOM_opacity.F90 | 4 ++-- src/tracer/MOM_CFC_cap.F90 | 2 +- src/tracer/MOM_tracer_diabatic.F90 | 4 ++-- src/tracer/dyed_obc_tracer.F90 | 2 +- src/tracer/oil_tracer.F90 | 14 +++++++------- 14 files changed, 42 insertions(+), 38 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 21c3e64488..83bfab0820 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -409,7 +409,7 @@ module MOM_barotropic !>@} !> A negligible parameter which avoids division by zero, but is too small to -!! modify physical values. +!! modify physical values [nondim]. real, parameter :: subroundoff = 1e-30 contains @@ -662,7 +662,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, time_bt_start, & ! The starting time of the barotropic steps. time_step_end, & ! The end time of a barotropic step. time_end_in ! The end time for diagnostics when this routine started. - real :: time_int_in ! The diagnostics' time interval when this routine started. + real :: time_int_in ! The diagnostics' time interval when this routine started [s] real :: Htot_avg ! The average total thickness of the tracer columns adjacent to a ! velocity point [H ~> m or kg m-2] logical :: do_hifreq_output ! If true, output occurs every barotropic step. @@ -3972,7 +3972,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain 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 + real, parameter :: C1_3 = 1.0/3.0 ! [nondim] integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -4107,7 +4107,7 @@ subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & ! Local variables real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] - real, parameter :: C1_3 = 1.0/3.0 + real, parameter :: C1_3 = 1.0/3.0 ! [nondim] integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 31f285c26f..36ba8b60f8 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -387,7 +387,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s 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, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2] real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] logical :: dyn_p_surf @@ -1055,8 +1055,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s endif if (CS%fpmix) then - if (CS%id_uold > 0) call post_data(CS%id_uold , uold, CS%diag) - if (CS%id_vold > 0) call post_data(CS%id_vold , vold, CS%diag) + if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) + if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) endif ! The time-averaged free surface height has already been set by the last call to btstep. @@ -1072,8 +1072,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_CAv > 0) call post_data(CS%id_CAv, CS%CAv, CS%diag) ! Here the thickness fluxes are offered for time averaging. - if (CS%id_uh > 0) call post_data(CS%id_uh , uh, CS%diag) - if (CS%id_vh > 0) call post_data(CS%id_vh , vh, CS%diag) + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) if (CS%id_uav > 0) call post_data(CS%id_uav, u_av, CS%diag) if (CS%id_vav > 0) call post_data(CS%id_vav, v_av, CS%diag) if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) @@ -1301,7 +1301,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) , & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< layer thickness [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & target, intent(inout) :: uh !< zonal volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index b5a17130e4..dcbf440292 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2169,7 +2169,7 @@ subroutine forcing_accumulate(flux_tmp, forces, fluxes, G, wt2) type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged !! thermodynamic forcing fields type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 !< The relative weight of the new fluxes + real, intent(out) :: wt2 !< The relative weight of the new fluxes [nondim] ! This subroutine copies mechancal forcing from flux_tmp to fluxes and ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, @@ -2187,7 +2187,7 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged !! thermodynamic forcing fields type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 !< The relative weight of the new fluxes + real, intent(out) :: wt2 !< The relative weight of the new fluxes [nondim] type(mech_forcing), optional, intent(in) :: forces !< A structure with the driving mechanical forces ! This subroutine copies mechanical forcing from flux_tmp to fluxes and diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 9cbf420b23..52e37f1a9b 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -136,14 +136,18 @@ module MOM_grid IareaBu !< IareaBu = 1/areaBu [L-2 ~> m-2]. real, pointer, dimension(:) :: & - gridLatT => NULL(), & !< The latitude of T points for the purpose of labeling the output axes. + gridLatT => NULL(), & !< The latitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatT. - gridLatB => NULL() !< The latitude of B points for the purpose of labeling the output axes. + gridLatB => NULL() !< The latitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatBu. real, pointer, dimension(:) :: & - gridLonT => NULL(), & !< The longitude of T points for the purpose of labeling the output axes. + gridLonT => NULL(), & !< The longitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonT. - gridLonB => NULL() !< The longitude of B points for the purpose of labeling the output axes. + gridLonB => NULL() !< The longitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonBu. character(len=40) :: & ! Except on a Cartesian grid, these are usually some variant of "degrees". @@ -187,8 +191,8 @@ module MOM_grid ! initialization routines (but not all) real :: south_lat !< The latitude (or y-coordinate) of the first v-line [degrees_N] or [km] or [m] real :: west_lon !< The longitude (or x-coordinate) of the first u-line [degrees_E] or [km] or [m] - real :: len_lat !< The latitudinal (or y-coord) extent of physical domain - real :: len_lon !< The longitudinal (or x-coord) extent of physical domain + real :: len_lat !< The latitudinal (or y-coord) extent of physical domain [degrees_N] or [km] or [m] + real :: len_lon !< The longitudinal (or x-coord) extent of physical domain [degrees_E] or [km] or [m] real :: Rad_Earth !< The radius of the planet [m] real :: Rad_Earth_L !< The radius of the planet in rescaled units [L ~> m] real :: max_depth !< The maximum depth of the ocean in depth units [Z ~> m] diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 3dfbc89a03..6681034cb9 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -66,7 +66,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) real :: p(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] real :: dz_geo(SZI_(G),SZJ_(G),SZK_(GV)) ! The change in geopotential height ! across a layer [L2 T-2 ~> m2 s-2]. - real :: dilate(SZI_(G)) ! non-dimensional dilation factor + real :: dilate(SZI_(G)) ! A non-dimensional dilation factor [nondim] real :: htot(SZI_(G)) ! total thickness [H ~> m or kg m-2] real :: I_gEarth ! The inverse of the gravitational acceleration times the ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 444ef8f064..1f73653aa3 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -837,7 +837,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d real :: muza ! mu(z) at top of the layer [nondim] real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim] - real, parameter :: two_thirds = 2./3. + real, parameter :: two_thirds = 2./3. ! [nondim] logical :: line_is_empty, keep_going integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -1156,7 +1156,7 @@ real elemental function rmean2ts(signal, filtered, tau_growing, tau_decaying, dt real, intent(in) :: tau_decaying ! Time scale for decaying signal [T ~> s] real, intent(in) :: dt ! Time step [T ~> s] ! Local variables - real :: afac, bfac ! Non-dimensional weights + real :: afac, bfac ! Non-dimensional fractional weights [nondim] real :: rt ! Reciprocal time scale [T-1 ~> s-1] if (signal>=filtered) then diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 248a90d76a..2638ca71e1 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1671,11 +1671,11 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration - !! of density gradients. + !! of density gradients [nondim]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: int_slope_v !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration - !! of density gradients. + !! of density gradients [nondim]. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & de_top ! The distances between the top of a layer and the top of the diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index eb481f2131..1cd8a45a78 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -256,7 +256,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. character(len=128) :: mesg character(len=200) :: tidal_input_files(4*MAX_CONSTITUENTS) - real :: tide_sal_scalar_value + real :: tide_sal_scalar_value ! The constant of proportionality with the scalar approximation to SAL [nondim] integer :: i, j, c, is, ie, js, je, isd, ied, jsd, jed, nc is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 380725b744..1a59b177bd 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -108,7 +108,7 @@ module MOM_energetic_PBL !/ mstar_scheme == 0 real :: fixed_mstar !< Mstar is the ratio of the friction velocity cubed to the TKE available to - !! drive entrainment, nondimensional. This quantity is the vertically + !! drive entrainment [nondim]. This quantity is the vertically !! integrated shear production minus the vertically integrated !! dissipation of TKE produced by shear. This value is used if the option !! for using a fixed mstar is used. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index bd1b804cba..61a7a0c7d0 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -422,7 +422,7 @@ function opacity_morel(chl_data) !> This sets the penetrating shortwave fraction according to the scheme proposed by !! Morel and Antoine (1994). function SW_pen_frac_morel(chl_data) - real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. + real, intent(in) :: chl_data !< The chlorophyll-A concentration [mg m-3] real :: SW_pen_frac_morel !< The returned penetrating shortwave fraction [nondim] ! The following are coefficients for the optical model taken from Morel and @@ -608,7 +608,7 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l real :: SW_trans ! fraction of shortwave radiation that is not ! absorbed in a layer [nondim] real :: unabsorbed ! fraction of the shortwave radiation that - ! is not absorbed because the layers are too thin + ! is not absorbed because the layers are too thin [nondim] real :: Ih_limit ! inverse of the total depth at which the ! surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] real :: h_min_heat ! minimum thickness layer that should get heated [H ~> m or kg m-2] diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 7539f05ba2..38777346a1 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -361,7 +361,7 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real :: flux_scale + real :: flux_scale ! A dimensional rescaling factor for fluxes [H R-1 Z-1 ~> m3 kg-1 or nondim] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 4e067e6896..f18c14e105 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -56,7 +56,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & btm_src !< The time-integrated bottom source of the tracer [CU H ~> CU m or CU kg m-2]. real, dimension(SZI_(G)) :: & b1, & !< b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - d1 !! d1=1-c1 is used by the tridiagonal solver, nondimensional. + d1 !! d1=1-c1 is used by the tridiagonal solver [nondim]. real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver [nondim]. real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the !! difference in sinking rates across the layer [H ~> m or kg m-2]. @@ -253,7 +253,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & btm_src !< The time-integrated bottom source of the tracer [CU H ~> CU m or CU kg m-2]. real, dimension(SZI_(G)) :: & b1, & !< b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - d1 !! d1=1-c1 is used by the tridiagonal solver, nondimensional. + d1 !! d1=1-c1 is used by the tridiagonal solver [nondim]. real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver [nondim]. real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the !! difference in sinking rates across the layer [H ~> m or kg m-2]. diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 285abe3785..92e10187a6 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -213,7 +213,7 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! fluxes can be applied [H ~> m or kg m-2] ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 71800284a6..fc8f82f0df 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -42,18 +42,18 @@ module oil_tracer character(len=200) :: IC_file !< The file in which the age-tracer initial values !! can be found, or an empty string for internal initialization. logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. - real :: oil_source_longitude !< Latitude of source location (geographic) - real :: oil_source_latitude !< Longitude of source location (geographic) - integer :: oil_source_i=-999 !< Local i of source location (computational) - integer :: oil_source_j=-999 !< Local j of source location (computational) + real :: oil_source_longitude !< Latitude of source location (geographic) [degrees_N] + real :: oil_source_latitude !< Longitude of source location (geographic) [degrees_E] + integer :: oil_source_i=-999 !< Local i of source location (computational index location) + integer :: oil_source_j=-999 !< Local j of source location (computational index location) real :: oil_source_rate !< Rate of oil injection [kg T-1 ~> kg s-1] real :: oil_start_year !< The time at which the oil source starts [years] real :: oil_end_year !< The time at which the oil source ends [years] type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? - real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. - real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, [kg m-3] + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value [kg m-3] + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out [kg m-3] real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [T-1 ~> s-1] calculated from oil_decay_days integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source logical :: oil_may_reinit !< If true, oil tracers may be reset by the initialization code From 11c3f56435345c7374d6113381e7d98f648ae797 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 11 Oct 2023 10:41:07 -0400 Subject: [PATCH 131/146] +Save tv%p_surf to some restart files Save tv%p_surf in the restart file when USE_PSURF_IN_EOS is true so that the diagnosed potential energy written to the ocean.stats files after a restart matches the energy written at the end of the previous run-segment in certain non-Boussinesq configurations, including the Baltic test case. Because p_surf_EOS is a non-mandatory restart field, there is no problem restarting the run from a restart file created by an older version of the model. The solutions themselves are bitwise identical. This change requires that tv%p_surf is treated as an allocatable pointer to its own array rather than being used as a pointer to the p_surf element of the fluxes or forces structures so that it can be registered as a restart field. At some point tv%p_surf could be converted into an allocatable array instead of a pointer, but this would require more extensive code refactoring. All answers are bitwise identical. --- src/core/MOM.F90 | 40 ++++++++++++++++++++++++---------------- 1 file changed, 24 insertions(+), 16 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index bb890d2d87..1460af1fa3 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -291,8 +291,6 @@ module MOM logical :: useMEKE !< If true, call the MEKE parameterization. logical :: use_stochastic_EOS !< If true, use the stochastic EOS parameterizations. logical :: useWaves !< If true, update Stokes drift - logical :: use_p_surf_in_EOS !< If true, always include the surface pressure contributions - !! in equation of state calculations. logical :: use_diabatic_time_bug !< If true, uses the wrong calendar time for diabatic processes, !! as was done in MOM6 versions prior to February 2018. real :: dtbt_reset_period !< The time interval between dynamic recalculation of the @@ -410,11 +408,11 @@ module MOM type(sponge_CS), pointer :: sponge_CSp => NULL() !< Pointer to the layered-mode sponge control structure type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() - !< Pointer to the oda incremental update control structure + !< Pointer to the ALE-mode sponge control structure type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() - !< Pointer to the internal tides control structure + !< Pointer to the oda incremental update control structure type(int_tide_CS), pointer :: int_tide_CSp => NULL() - !< Pointer to the ALE-mode sponge control structure + !< Pointer to the internal tides control structure type(ALE_CS), pointer :: ALE_CSp => NULL() !< Pointer to the Arbitrary Lagrangian Eulerian (ALE) vertical coordinate control structure @@ -634,6 +632,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif endif + ! This will be replaced later with the pressures from forces or fluxes if they are available. + if (associated(CS%tv%p_surf)) CS%tv%p_surf(:,:) = 0.0 + ! First determine the time step that is consistent with this call and an ! integer fraction of time_interval. if (do_dyn) then @@ -657,8 +658,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS !---------- Initiate group halo pass of the forcing fields call cpu_clock_begin(id_clock_pass) + ! Halo updates for surface pressure need to be completed before calling calc_resoln_function + ! among other routines if the surface pressure is used in the equation of state. nonblocking_p_surf_update = G%nonblocking_updates .and. & - .not.(CS%use_p_surf_in_EOS .and. associated(forces%p_surf) .and. & + .not.(associated(CS%tv%p_surf) .and. associated(forces%p_surf) .and. & allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) if (.not.associated(forces%taux) .or. .not.associated(forces%tauy)) & call MOM_error(FATAL,'step_MOM:forces%taux,tauy not associated') @@ -678,9 +681,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (associated(forces%p_surf)) p_surf => forces%p_surf if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. - CS%tv%p_surf => NULL() - if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) then - CS%tv%p_surf => forces%p_surf + if (associated(CS%tv%p_surf) .and. associated(forces%p_surf)) then + do j=jsd,jed ; do i=isd,ied ; CS%tv%p_surf(i,j) = forces%p_surf(i,j) ; enddo ; enddo if (allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) then ! The internal ocean state depends on the surface pressues, so update SpV_avg. @@ -704,11 +706,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call pass_var(fluxes%tau_mag, G%Domain, clock=id_clock_pass, halo=1) if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf - CS%tv%p_surf => NULL() - if (CS%use_p_surf_in_EOS .and. associated(fluxes%p_surf)) then - CS%tv%p_surf => fluxes%p_surf + if (associated(CS%tv%p_surf) .and. associated(fluxes%p_surf)) then + do j=js,je ; do i=is,ie ; CS%tv%p_surf(i,j) = fluxes%p_surf(i,j) ; enddo ; enddo if (allocated(CS%tv%SpV_avg)) then - call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) + call pass_var(CS%tv%p_surf, G%Domain, clock=id_clock_pass) ! The internal ocean state depends on the surface pressues, so update SpV_avg. call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) halo_sz = max(halo_sz, 1) @@ -2040,6 +2041,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & logical :: bulkmixedlayer ! If true, a refined bulk mixed layer scheme is used ! with nkml sublayers and nkbl buffer layer. logical :: use_temperature ! If true, temperature and salinity used as state variables. + logical :: use_p_surf_in_EOS ! If true, always include the surface pressure contributions + ! in equation of state calculations. logical :: use_frazil ! If true, liquid seawater freezes if temp below freezing, ! with accumulated heat deficit returned to surface ocean. logical :: bound_salinity ! If true, salt is added to keep salinity above @@ -2301,7 +2304,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(CS%OBC)) ! This is here in case these values are used inappropriately. - use_frazil = .false. ; bound_salinity = .false. + use_frazil = .false. ; bound_salinity = .false. ; use_p_surf_in_EOS = .false. CS%tv%P_Ref = 2.0e7*US%Pa_to_RL2_T2 if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & @@ -2330,7 +2333,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & "This is only used if ENABLE_THERMODYNAMICS is true. The default "//& "value is from the TEOS-10 definition of conservative temperature.", & units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q*US%C_to_degC) - call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", CS%use_p_surf_in_EOS, & + call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", use_p_surf_in_EOS, & "If true, always include the surface pressure contributions "//& "in equation of state calculations.", default=.true.) endif @@ -2656,6 +2659,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif endif + if (use_p_surf_in_EOS) allocate(CS%tv%p_surf(isd:ied,jsd:jed), source=0.0) if (use_frazil) allocate(CS%tv%frazil(isd:ied,jsd:jed), source=0.0) if (bound_salinity) allocate(CS%tv%salt_deficit(isd:ied,jsd:jed), source=0.0) @@ -3205,8 +3209,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call do_group_pass(pass_uv_T_S_h, G%Domain) ! Update derived thermodynamic quantities. + if (associated(CS%tv%p_surf)) call pass_var(CS%tv%p_surf, G%Domain, halo=dynamics_stencil) if (allocated(CS%tv%SpV_avg)) then - !### There may be a restart issue here with the surface pressure not being updated? call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif @@ -3446,6 +3450,10 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) "Previous ocean surface pressure", "Pa", conversion=US%RL2_T2_to_Pa) endif + if (associated(CS%tv%p_surf)) & + call register_restart_field(CS%tv%p_surf, "p_surf_EOS", .false., restart_CSp, & + "Ocean surface pressure used in EoS", "Pa", conversion=US%RL2_T2_to_Pa) + call register_restart_field(CS%ave_ssh_ibc, "ave_ssh", .false., restart_CSp, & "Time average sea surface height", "meter", conversion=US%Z_to_m) From ab54a1ec4bebfcf7444ebe8646a5471fdf32487d Mon Sep 17 00:00:00 2001 From: alex-huth Date: Fri, 27 Oct 2023 17:23:27 -0400 Subject: [PATCH 132/146] Added capability to write an ice_shelf.stats file (or with custom filename specified by new parameter ICE_SHELF_ENERGYFILE). Currently, this file outputs the kinetic energy and mass of the ice sheet according to the smae parameters used to write the ocean.stats file (TIMEUNIT, ENERGYSAVEDAYS, and ENERGYSAVEDAYS_GEOMETRIC). --- .../STALE_mct_cap/mom_ocean_model_mct.F90 | 2 +- .../ice_solo_driver/ice_shelf_driver.F90 | 3 +- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 2 +- src/core/MOM.F90 | 5 +- src/ice_shelf/MOM_ice_shelf.F90 | 31 ++- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 205 +++++++++++++++++- 6 files changed, 230 insertions(+), 18 deletions(-) diff --git a/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 index 82d8881c03..d1c46f4254 100644 --- a/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 @@ -369,7 +369,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) + OS%diag, Time_init, OS%dirs%output_directory, OS%forces, OS%fluxes) endif if (OS%icebergs_alter_ocean) then diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index f91595bd51..c4be8c769d 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -283,7 +283,8 @@ program Shelf_main call set_axes_info(ocn_grid, GV, US, param_file, diag) - call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, fluxes_in=fluxes, solo_ice_sheet_in=.true.) + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, & + Start_time, dirs%output_directory, fluxes_in=fluxes, solo_ice_sheet_in=.true.) call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, ocn_grid, US, param_file) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index b4a9f1d604..9ac40daaa4 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -390,7 +390,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) + OS%diag, Time_init, OS%dirs%output_directory, OS%forces, OS%fluxes) endif if (OS%icebergs_alter_ocean) then call marine_ice_init(OS%Time, OS%grid, param_file, OS%diag, OS%marine_ice_CSp) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 1460af1fa3..a823ce1744 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2853,7 +2853,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! These arrays are not initialized in most solo cases, but are needed ! when using an ice shelf. Passing the ice shelf diagnostics CS from MOM ! for legacy reasons. The actual ice shelf diag CS is internal to the ice shelf - call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr) + call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr, & + Time_init, dirs%output_directory) allocate(frac_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(mass_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) @@ -2912,7 +2913,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & deallocate(frac_shelf_in,mass_shelf_in) else if (use_ice_shelf) then - call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr) + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, Time_init, dirs%output_directory) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 84858f17bc..d7aacef8ed 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -48,7 +48,7 @@ module MOM_ice_shelf use MOM_get_input, only : directories, Get_MOM_input use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze, EOS_domain use MOM_EOS, only : EOS_type, EOS_init -use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf +use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf, write_ice_shelf_energy use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end @@ -162,6 +162,8 @@ module MOM_ice_shelf type(EOS_type) :: eqn_of_state !< Type that indicates the equation of state to use. logical :: active_shelf_dynamics !< True if the ice shelf mass changes as a result !! the dynamic ice-shelf model. + logical :: shelf_mass_is_dynamic !< True if ice shelf mass changes over time. If true, ice + !! shelf dynamics will be initialized logical :: data_override_shelf_fluxes !< True if the ice shelf surface mass fluxes can be !! written using the data_override feature (only for MOSAIC grids) logical :: override_shelf_movement !< If true, user code specifies the shelf movement @@ -784,6 +786,10 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) endif + if (CS%shelf_mass_is_dynamic) & + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & + time_step=real_to_time(US%T_to_s*time_step) ) + call enable_averages(time_step, Time, CS%diag) if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) @@ -1211,14 +1217,16 @@ end subroutine add_shelf_flux !> Initializes shelf model data, parameters and diagnostics -subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, & - fluxes_in, sfc_state_in, Time_in, solo_ice_sheet_in) +subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, directory, forces_in, & + fluxes_in, sfc_state_in, solo_ice_sheet_in) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(MOM_diag_ctrl), pointer :: diag !< This is a pointer to the MOM diag CS !! which will be discarded + type(time_type), intent(in) :: Time_init !< The time at initialization. + character(len=*), intent(in) :: directory !< The directory where the energy file goes. type(mech_forcing), optional, target, intent(inout) :: forces_in !< A structure with the driving mechanical forces type(forcing), optional, target, intent(inout) :: fluxes_in !< A structure containing pointers to any @@ -1226,7 +1234,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, type(surface), target, optional, intent(inout) :: sfc_state_in !< A structure containing fields that !! describe the surface state of the ocean. The !! intent is only inout to allow for halo updates. - type(time_type), optional, intent(in) :: Time_in !< The time at initialization. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether !! a solo ice-sheet driver. @@ -1248,7 +1255,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) - logical :: read_TideAmp, shelf_mass_is_dynamic, debug + logical :: read_TideAmp, debug logical :: global_indexing character(len=240) :: Tideamp_file ! Input file names character(len=80) :: tideamp_var ! Input file variable names @@ -1363,7 +1370,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%solo_ice_sheet = .false. if (present(solo_ice_sheet_in)) CS%solo_ice_sheet = solo_ice_sheet_in - if (present(Time_in)) Time = Time_in + !if (present(Time_in)) Time = Time_in CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. @@ -1373,10 +1380,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & "If true, write verbose debugging messages for the ice shelf.", & default=debug) - call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", CS%shelf_mass_is_dynamic, & "If true, the ice sheet mass can evolve with time.", & default=.false.) - if (shelf_mass_is_dynamic) then + if (CS%shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", CS%override_shelf_movement, & "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false.) @@ -1777,8 +1784,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ISS%water_flux(:,:) = 0.0 endif - if (shelf_mass_is_dynamic) & - call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, solo_ice_sheet_in) + if (CS%shelf_mass_is_dynamic) & + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, & + Time_init, directory, solo_ice_sheet_in) call fix_restart_unit_scaling(US, unscaled=.true.) @@ -2245,6 +2253,9 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in enddo + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & + time_step=real_to_time(US%T_to_s*time_step) ) + call enable_averages(full_time_step, Time, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 2965f6eac4..42416ce807 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -16,8 +16,12 @@ module MOM_ice_shelf_dynamics use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_io, only : file_exists, slasher, MOM_read_data +use MOM_io, only : open_ASCII_file, get_filename_appendix +use MOM_io, only : APPEND_FILE, WRITEONLY_FILE use MOM_restart, only : register_restart_field, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time +use MOM_time_manager, only : time_type, get_time, set_time, time_type_to_real, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state @@ -31,7 +35,7 @@ module MOM_ice_shelf_dynamics #include public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf -public ice_time_step_CFL, ice_shelf_dyn_end +public ice_time_step_CFL, ice_shelf_dyn_end, write_ice_shelf_energy public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -167,6 +171,27 @@ module MOM_ice_shelf_dynamics !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm !! 3: exit based on change of norm + ! for write_ice_shelf_energy + type(time_type) :: energysavedays !< The interval between writing the energies + !! and other integral quantities of the run. + type(time_type) :: energysavedays_geometric !< The starting interval for computing a geometric + !! progression of time deltas between calls to + !! write_energy. This interval will increase by a factor of 2. + !! after each call to write_energy. + logical :: energysave_geometric !< Logical to control whether calls to write_energy should + !! follow a geometric progression + type(time_type) :: write_energy_time !< The next time to write to the energy file. + type(time_type) :: geometric_end_time !< Time at which to stop the geometric progression + !! of calls to write_energy and revert to the standard + !! energysavedays interval + real :: timeunit !< The length of the units for the time axis and certain input parameters + !! including ENERGYSAVEDAYS [s]. + type(time_type) :: Start_time !< The start time of the simulation. + ! Start_time is set in MOM_initialization.F90 + integer :: prev_IS_energy_calls = 0 !< The number of times write_ice_shelf_energy has been called. + integer :: IS_fileenergy_ascii !< The unit number of the ascii version of the energy file. + character(len=200) :: IS_energyfile !< The name of the ice sheet energy file with path. + ! ids for outputting intermediate thickness in advection subroutine (debugging) !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 @@ -329,7 +354,8 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) end subroutine register_ice_shelf_dyn_restarts !> Initializes shelf model data, parameters and diagnostics -subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, solo_ice_sheet_in) +subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, & + Input_start_time, directory, solo_ice_sheet_in) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe @@ -340,6 +366,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise !! has been started from a restart file. + type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. + character(len=*), intent(in) :: directory !< The directory where the ice sheet energy file goes. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether !! a solo ice-sheet driver. @@ -354,6 +382,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics logical :: debug integer :: i, j, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + character(len=200) :: IS_energyfile ! The name of the energy file. + character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -483,6 +513,43 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "Min thickness rule for the VERY simple calving law",& units="m", default=0.0, scale=US%m_to_Z) + !for write_ice_shelf_energy + ! Note that the units of CS%Timeunit are the MKS units of [s]. + call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & + "The time unit in seconds a number of input fields", & + units="s", default=86400.0) + if (CS%Timeunit < 0.0) CS%Timeunit = 86400.0 + call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & + "The interval in units of TIMEUNIT between saves of the "//& + "energies of the run and other globally summed diagnostics.",& + default=set_time(0,days=1), timeunit=CS%Timeunit) + call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & + "The starting interval in units of TIMEUNIT for the first call "//& + "to save the energies of the run and other globally summed diagnostics. "//& + "The interval increases by a factor of 2. after each call to write_ice_shelf_energy.",& + default=set_time(seconds=0), timeunit=CS%Timeunit) + if ((time_type_to_real(CS%energysavedays_geometric) > 0.) .and. & + (CS%energysavedays_geometric < CS%energysavedays)) then + CS%energysave_geometric = .true. + else + CS%energysave_geometric = .false. + endif + CS%Start_time = Input_start_time + call get_param(param_file, mdl, "ICE_SHELF_ENERGYFILE", IS_energyfile, & + "The file to use to write the energies and globally "//& + "summed diagnostics.", default="ice_shelf.stats") + !query fms_io if there is a filename_appendix (for ensemble runs) + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + IS_energyfile = trim(IS_energyfile) //'.'//trim(filename_appendix) + endif + + CS%IS_energyfile = trim(slasher(directory))//trim(IS_energyfile) + call log_param(param_file, mdl, "output_path/ENERGYFILE", CS%IS_energyfile) +#ifdef STATSLABEL + CS%IS_energyfile = trim(CS%IS_energyfile)//"."//trim(adjustl(STATSLABEL)) +#endif + ! Allocate memory in the ice shelf dynamics control structure that was not ! previously allocated for registration for restarts. @@ -810,6 +877,138 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled end subroutine update_ice_shelf +!> Writes the total ice shelf kinetic energy and mass to an ascii file +subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: mass !< The mass per unit area of the ice shelf + !! or sheet [R Z ~> kg m-2] + type(time_type), intent(in) :: day !< The current model time. + type(time_type), optional, intent(in) :: time_step !< The current time step + ! Local variables + type(time_type) :: dt ! A time_type version of the timestep. + real, dimension(SZDI_(G),SZDJ_(G)) :: tmp1 ! A temporary array used in reproducing sums [various] + real :: KE_tot, mass_tot, KE_scale_factor, mass_scale_factor + integer :: is, ie, js, je, isr, ier, jsr, jer, i, j + character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str + integer :: start_of_day, num_days + real :: reday ! Time in units given by CS%Timeunit, but often [days] + + ! write_energy_time is the next integral multiple of energysavedays. + if (present(time_step)) then + dt = time_step + else + dt = set_time(seconds=2) + endif + + !CS%prev_IS_energy_calls tracks the ice sheet step, which is outputted in the energy file. + if (CS%prev_IS_energy_calls == 0) then + if (CS%energysave_geometric) then + if (CS%energysavedays_geometric < CS%energysavedays) then + CS%write_energy_time = day + CS%energysavedays_geometric + CS%geometric_end_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + elseif (day + (dt/2) <= CS%write_energy_time) then + CS%prev_IS_energy_calls = CS%prev_IS_energy_calls + 1 + return ! Do not write this step + else ! Determine the next write time before proceeding + if (CS%energysave_geometric) then + if (CS%write_energy_time + CS%energysavedays_geometric >= & + CS%geometric_end_time) then + CS%write_energy_time = CS%geometric_end_time + CS%energysave_geometric = .false. ! stop geometric progression + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays_geometric + endif + CS%energysavedays_geometric = CS%energysavedays_geometric*2 + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays + endif + endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + + !calculate KE using cell-centered ice shelf velocity + tmp1(:,:)=0.0 + KE_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 * US%L_T_to_m_s**2 + do j=js,je ; do i=is,ie + tmp1(i,j) = KE_scale_factor * 0.03125 * G%areaT(i,j) * mass(i,j) * & + ((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J-1)+CS%u_shelf(I,J)+CS%u_shelf(I,J-1))**2 + & + (CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J-1)+CS%v_shelf(I,J)+CS%v_shelf(I,J-1))**2) + enddo; enddo + + KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) + + !calculate mass + tmp1(:,:)=0.0 + mass_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 + do j=js,je ; do i=is,ie + tmp1(i,j) = mass_scale_factor * mass(i,j) * G%areaT(i,j) + enddo; enddo + + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) + + if (is_root_pe()) then ! Only the root PE actually writes anything. + if (day > CS%Start_time) then + call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=APPEND_FILE) + else + call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=WRITEONLY_FILE) + if (abs(CS%timeunit - 86400.0) < 1.0) then + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Day,"8x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(12x,"[days]",10x,"[m2 s-2]",17x,"[kg]")') + else + if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then + time_units = " [seconds] " + elseif ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then + time_units = " [hours] " + elseif ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then + time_units = " [days] " + elseif ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then + time_units = " [years] " + else + write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit + endif + + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Time,"7x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(A25,3x,"[m2 s-2]",17x,"[kg]")') time_units + endif + endif + + call get_time(day, start_of_day, num_days) + + if (abs(CS%timeunit - 86400.0) < 1.0) then + reday = REAL(num_days)+ (REAL(start_of_day)/86400.0) + else + reday = REAL(num_days)*(86400.0/CS%timeunit) + REAL(start_of_day)/abs(CS%timeunit) + endif + + if (reday < 1.0e8) then ; write(day_str, '(F12.3)') reday + elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday + else ; write(day_str, '(ES15.9)') reday ; endif + + if (CS%prev_IS_energy_calls < 1000000) then ; write(n_str, '(I6)') CS%prev_IS_energy_calls + elseif (CS%prev_IS_energy_calls < 10000000) then ; write(n_str, '(I7)') CS%prev_IS_energy_calls + elseif (CS%prev_IS_energy_calls < 100000000) then ; write(n_str, '(I8)') CS%prev_IS_energy_calls + else ; write(n_str, '(I10)') CS%prev_IS_energy_calls ; endif + + write(CS%IS_fileenergy_ascii,'(A,",",A,", En ",ES22.16,", M ",ES11.5)') & + trim(n_str), trim(day_str), KE_tot/mass_tot, mass_tot + endif + + CS%prev_IS_energy_calls = CS%prev_IS_energy_calls + 1 +end subroutine write_ice_shelf_energy + !> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. !! Additionally, it will update the volume of ice in partially-filled cells, and update !! hmask accordingly From 3ab3dfc18b95b2c8948fb32ed8907e5d2a7095b6 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Thu, 2 Nov 2023 13:59:27 -0400 Subject: [PATCH 133/146] Fix ice-sheet grounding based on ocean column thickness (#512) A few bug fixes so that the GL_couple=.true. option works correctly. Setting GL_couple=.true. will determine the grounding based on ocean column thickness rather than the typical the hydrostatic equilibrium condition. This has the advantage of accounting for changes in sea level, tides, etc. However, it has the disadvantage of not working with the same thoroughly-tested sub-element grounding line parameterization used for the hydrostatic condition. Instead, it accounts for sub-element grounding line movement by, during the SSA solution, using a grounding mask averaged over all ocean (sub)steps that completed since the last SSA solve. Unlike the hydrostatic sub-element parameterization, the dependence of the GL_couple=.true. scheme on grid resolution has not yet been determined. Qualitatively similar grounding line retreat/advance behavior is achieved with both approaches for MISOMIP IceOcean1 on a 2km grid, but GL_couple=.true. results in a rougher grounding line position with less retreat. Note that this commit also fixed a bug in applying the hydrostatic grounding line approach without its sub-element parameterization (though the sub-element parameterization should also be used anyway). --- src/ice_shelf/MOM_ice_shelf.F90 | 1 + src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 89 ++++++++++++++---------- 2 files changed, 55 insertions(+), 35 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d7aacef8ed..5c67a66262 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1402,6 +1402,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. + if (CS%solo_ice_sheet) CS%GL_couple = .false. endif call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 42416ce807..8a95ce46d2 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -432,6 +432,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. + if (present(solo_ice_sheet_in)) then + if (solo_ice_sheet_in) CS%GL_couple = .false. + endif if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & @@ -826,6 +829,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled call update_OD_ffrac(CS, G, US, ocean_mass, update_ice_vel) elseif (update_ice_vel) then call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + CS%GL_couple=.false. endif @@ -1121,8 +1125,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice - ! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! If GL_regularize=true, an array indicating where the ice + ! shelf is floating: 0 if floating, 1 if not real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Used for convergence character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter @@ -1148,18 +1152,18 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! need to make these conditional on GL interpolation float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 - CS%ground_frac(:,:) = 0.0 + !CS%ground_frac(:,:) = 0.0 allocate(Phisub(nsub,nsub,2,2,2,2), source=0.0) - do j=G%jsc,G%jec - do i=G%isc,G%iec + if (.not. CS%GL_couple) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) > 0) then - float_cond(i,j) = 1.0 + if (CS%GL_regularize) float_cond(i,j) = 1.0 CS%ground_frac(i,j) = 1.0 CS%OD_av(i,j) =0.0 endif - enddo - enddo + enddo ; enddo + endif call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) @@ -1209,10 +1213,15 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! This makes sure basal stress is only applied when it is supposed to be - do j=G%jsd,G%jed ; do i=G%isd,G%ied -! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) - enddo ; enddo + if (CS%GL_regularize) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + enddo ; enddo + endif if (CS%nonlin_solve_err_mode == 1) then ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & @@ -1284,11 +1293,15 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! makes sure basal stress is only applied when it is supposed to be - - do j=G%jsd,G%jed ; do i=G%isd,G%ied -! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) - enddo ; enddo + if (CS%GL_regularize) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + enddo ; enddo + endif if (CS%nonlin_solve_err_mode == 1) then !u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 @@ -1395,8 +1408,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -2139,18 +2152,24 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) rhoi_rhow = rho/rhow ! prelim - go through and calculate S - S(:,:) = -CS%bed_elev(:,:) + ISS%h_shelf(:,:) - ! check whether the ice is floating or grounded - - do j=jsc-G%domain%njhalo,jec+G%domain%njhalo - do i=isc-G%domain%nihalo,iec+G%domain%nihalo - if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then - S(i,j) = (1 - rhoi_rhow)*ISS%h_shelf(i,j) - else - S(i,j) = ISS%h_shelf(i,j)-CS%bed_elev(i,j) - endif + if (CS%GL_couple) then + do j=jsc-G%domain%njhalo,jec+G%domain%njhalo + do i=isc-G%domain%nihalo,iec+G%domain%nihalo + S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + ISS%h_shelf(i,j)) + enddo enddo - enddo + else + ! check whether the ice is floating or grounded + do j=jsc-G%domain%njhalo,jec+G%domain%njhalo + do i=isc-G%domain%nihalo,iec+G%domain%nihalo + if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then + S(i,j) = (1 - rhoi_rhow)*ISS%h_shelf(i,j) + else + S(i,j) = ISS%h_shelf(i,j)-CS%bed_elev(i,j) + endif + enddo + enddo + endif call pass_var(S, G%domain) @@ -2413,8 +2432,8 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points !! relative to sea-level [Z ~> m]. @@ -2584,8 +2603,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. @@ -3115,7 +3134,7 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) CS%ground_frac(i,j) = 1.0 - (CS%ground_frac_rt(i,j) * I_counter) CS%OD_av(i,j) = CS%OD_rt(i,j) * I_counter - CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 + CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0; CS%OD_rt_counter = 0 enddo ; enddo call pass_var(CS%ground_frac, G%domain, complete=.false.) From d85fe733fdfb81db591215b3c2a10cd62b61b7bb Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Mon, 6 Nov 2023 20:33:57 -0500 Subject: [PATCH 134/146] ice-sheet/ocean coupling for misomip (#511) * This commit fixes a bug where restarts were not bitwise identical for coupled ice sheet/ocean runs. This required adding visc%taux and visc%taux (stress on the ocean under ice shelves) to the ocean restart file. Furthermore, ice shelf geometry-related variables needed to be updated and their halo cells filled (within subroutine update_ice_shelf) before (rather than after) calculating shelf fluxes and pressure to the ocean (subroutine add_shelf_flux). Also fixed a bug to calculate ISS%mass_shelf properly in ice-shelf cells that are only partially-filled (ice-shelf area < cell area) due to advection of the ice-shelf front. * Modified the scheme that attempts to enforce a constant sea level in coupled ice-sheet/ocean runs, where balancing fluxes are applied to part/all of the open ocean to offset the sea level effects caused by changes in ice sheet mass on the ocean. The old scheme assumes the entire ice sheet is floating, and is retained here for the case where CS$override_shelf_movement==.true. and CS%mass_from_file (this approach is used for the MISOMIP tests without a dynamic ice sheet). The new scheme (which is needed for the MISOMIP tests with a dynamic ice sheet, e.g. IceOcean1r and IceOcean1a), accounts for the more general case where some of the ice sheet is grounded. In either case, the ocean balancing fluxes are applied over the entirety of the ice-sheet-free ocean by default. However, if the new parameter CONST_SEA_LEVEL_MISOMIP==.true., the balancing flux is only applied where x>=790 km, which is the sponge region for the MISOMIP tests. The new scheme also requires calculation of ice sheet dHdT, which is now calculated and optionally saved as a useful diagnositc field for any ice sheet simulation. * Eliminated array syntax and added inverse dt variables where needed --- src/core/MOM.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 88 +++++++++++++------ src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 58 +++++++++++- src/ice_shelf/MOM_ice_shelf_state.F90 | 4 +- .../vertical/MOM_set_viscosity.F90 | 22 ++++- 5 files changed, 143 insertions(+), 31 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a823ce1744..e1fa004fb8 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2752,7 +2752,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%tracer_Reg, restart_CSp) call MEKE_alloc_register_restart(HI, US, param_file, CS%MEKE, restart_CSp) - call set_visc_register_restarts(HI, GV, US, param_file, CS%visc, restart_CSp) + call set_visc_register_restarts(HI, G, GV, US, param_file, CS%visc, restart_CSp, use_ice_shelf) call mixedlayer_restrat_register_restarts(HI, GV, US, param_file, & CS%mixedlayer_restrat_CSp, restart_CSp) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5c67a66262..b435b0a677 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -50,7 +50,7 @@ module MOM_ice_shelf use MOM_EOS, only : EOS_type, EOS_init use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf, write_ice_shelf_energy use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn -use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve +use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve, change_in_draft use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end use MOM_ice_shelf_initialize, only : initialize_ice_thickness !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary @@ -177,6 +177,8 @@ module MOM_ice_shelf logical :: const_gamma !< If true, gamma_T is specified by the user. logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. + logical :: constant_sea_level_misomip !< If true, constant_sea_level fluxes are applied only over + !! the surface sponge cells from the ISOMIP/MISOMIP configuration real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice !! shelf is considered to float when constant_sea_level !! is used [R Z ~> kg m-2] @@ -200,7 +202,7 @@ module MOM_ice_shelf id_tfreeze = -1, id_tfl_shelf = -1, & id_thermal_driving = -1, id_haline_driving = -1, & id_u_ml = -1, id_v_ml = -1, id_sbdry = -1, & - id_h_shelf = -1, id_h_mask = -1, & + id_h_shelf = -1, id_dhdt_shelf, id_h_mask = -1, & id_surf_elev = -1, id_bathym = -1, & id_area_shelf_h = -1, & id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1, & @@ -271,6 +273,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) !! interface, positive for melting and negative for freezing [S ~> ppt]. !! This is computed as part of the ISOMIP diagnostics. real :: time_step !< Length of time over which these fluxes will be applied [T ~> s]. + real :: Itime_step !< Inverse of the length of time over which these fluxes will be applied [T-1 ~> s-1] real :: VK !< Von Karman's constant - dimensionless real :: ZETA_N !< This is the stability constant xi_N = 0.052 from Holland & Jenkins '99 !! divided by the von Karman constant VK. Was 1/8. [nondim] @@ -751,6 +754,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ! Melting has been computed, now is time to update thickness and mass with dynamic ice shelf if (CS%active_shelf_dynamics) then + + ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) if (CS%debug) then @@ -767,29 +773,29 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) scale=US%RZ_to_kg_m2) endif - endif - - if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) - - call add_shelf_flux(G, US, CS, sfc_state, fluxes) - - ! now the thermodynamic data is passed on... time to update the ice dynamic quantities - - if (CS%active_shelf_dynamics) then update_ice_vel = .false. - coupled_GL = (CS%GL_couple .and. .not.CS%solo_ice_sheet) + coupled_GL = (CS%GL_couple .and. .not. CS%solo_ice_sheet) ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, & sfc_state%ocean_mass, coupled_GL) + Itime_step = 1./time_step + do j=js,je ; do i=is,ie + ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j))*Itime_step + enddo; enddo endif if (CS%shelf_mass_is_dynamic) & call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & time_step=real_to_time(US%T_to_s*time_step) ) + if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) + + ! pass on the updated ice sheet geometry (for pressure on ocean) and thermodynamic data + call add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) + call enable_averages(time_step, Time, CS%diag) if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) @@ -808,6 +814,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, exch_vel_t, CS%diag) if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, exch_vel_s, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) call disable_averaging(CS%diag) @@ -860,7 +867,7 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * density_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * density_ice endif enddo ; enddo @@ -1018,13 +1025,13 @@ subroutine add_shelf_pressure(Ocn_grid, US, CS, fluxes) end subroutine add_shelf_pressure !> Updates surface fluxes that are influenced by sub-ice-shelf melting -subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) +subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) 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(ice_shelf_CS), pointer :: CS !< This module's control structure. type(surface), intent(inout) :: sfc_state !< Surface ocean state type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. - + real, intent(in) :: time_step !< Time step over which fluxes are applied ! local variables real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. @@ -1045,6 +1052,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) !! at at previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area [L2 ~> m2] !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: delta_draft !< change in ice shelf draft thickness [L ~> m] + !! since previous time (Time-dt) type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe !! the ice-shelf state @@ -1171,22 +1180,38 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) else! first time step delta_mass_shelf = 0.0 endif - else ! ice shelf mass does not change - delta_mass_shelf = 0.0 + else + if (CS%active_shelf_dynamics) then ! change in ice_shelf draft + do j=js,je ; do i=is,ie + last_h_shelf(i,j) = ISS%h_shelf(i,j) - time_step * ISS%dhdt_shelf(i,j) + enddo ; enddo + call change_in_draft(CS%dCS, G, last_h_shelf, ISS%h_shelf, delta_draft) + + !this currently assumes area_shelf_h is constant over the time step + delta_mass_shelf = global_area_integral(delta_draft, G, tmp_scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) & + * CS%Rho_ocn / CS%time_step + else ! ice shelf mass does not change + delta_mass_shelf = 0.0 + endif endif - ! average total melt flux over sponge area + ! average total melt flux over sponge area (ISOMIP/MISOMIP only) or open ocean (general case) do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .AND. (ISS%area_shelf_h(i,j) * G%IareaT(i,j) < 1.0)) then - ! Uncomment this for some ISOMIP cases: - ! .AND. (G%geoLonT(i,j) >= 790.0) .AND. (G%geoLonT(i,j) <= 800.0)) then + if (CS%constant_sea_level_misomip) then !for ismip/misomip only + if (G%geoLonT(i,j) >= 790.0) then + bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) + else + bal_frac(i,j) = 0.0 + endif + elseif ((G%mask2dT(i,j) > 0.0) .and. (ISS%area_shelf_h(i,j) * G%IareaT(i,j) < 1.0)) then !general case bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) else bal_frac(i,j) = 0.0 endif enddo ; enddo - balancing_area = global_area_integral(bal_frac, G) + balancing_area = global_area_integral(bal_frac, G, area=G%areaT) if (balancing_area > 0.0) then balancing_flux = ( global_area_integral(ISS%water_flux, G, tmp_scale=US%RZ_T_to_kg_m2s, & area=ISS%area_shelf_h) + & @@ -1430,6 +1455,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, "ISOMIP+ experiments (Ocean3 and Ocean4). "//& "IMPORTANT: it is not currently possible to do "//& "prefect restarts using this flag.", default=.false.) + call get_param(param_file, mdl, "CONST_SEA_LEVEL_MISOMIP", CS%constant_sea_level_misomip, & + "If true, constant_sea_level fluxes are applied only over "//& + "the surface sponge cells from the ISOMIP/MISOMIP configuration", default=.false.) call get_param(param_file, mdl, "MIN_OCEAN_FLOAT_THICK", dz_ocean_min_float, & "The minimum ocean thickness above which the ice shelf is considered to be "//& "floating when CONST_SEA_LEVEL = True.", & @@ -1809,6 +1837,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, 'mass of shelf', 'kg/m^2', conversion=US%RZ_to_kg_m2) CS%id_h_shelf = register_diag_field('ice_shelf_model', 'h_shelf', CS%diag%axesT1, CS%Time, & 'ice shelf thickness', 'm', conversion=US%Z_to_m) + CS%id_dhdt_shelf = register_diag_field('ice_shelf_model', 'dhdt_shelf', CS%diag%axesT1, CS%Time, & + 'change in ice shelf thickness over time', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_mass_flux = register_diag_field('ice_shelf_model', 'mass_flux', CS%diag%axesT1,& CS%Time, 'Total mass flux of freshwater across the ice-ocean interface.', & 'kg/s', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2) @@ -2050,7 +2080,7 @@ subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * CS%density_ice endif enddo ; enddo @@ -2204,20 +2234,22 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in real :: remaining_time ! The remaining time in this call [T ~> s] real :: time_step ! The internal time step during this call [T ~> s] real :: full_time_step ! The external time step (sum of internal time steps) during this call [T ~> s] + real :: Ifull_time_step ! The inverse of the external time step [T-1 ~> s-1] real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] character(len=240) :: mesg logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true the grounding line position is determined based on ! coupled ice-ocean dynamics. - integer :: is, iec, js, jec + integer :: is, ie, js, je, i, j G => CS%grid US => CS%US ISS => CS%ISS - is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec remaining_time = US%s_to_T*time_type_to_real(time_interval) full_time_step = remaining_time + Ifull_time_step = 1./full_time_step if (present (min_time_step_in)) then min_time_step = min_time_step_in @@ -2228,6 +2260,8 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.) call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) + ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + do while (remaining_time > 0.0) nsteps = nsteps+1 @@ -2256,10 +2290,14 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & time_step=real_to_time(US%T_to_s*time_step) ) + do j=js,je ; do i=is,ie + ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j)) * Ifull_time_step + enddo; enddo call enable_averages(full_time_step, Time, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) call disable_averaging(CS%diag) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8a95ce46d2..312fa43fe9 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -35,7 +35,7 @@ module MOM_ice_shelf_dynamics #include public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf -public ice_time_step_CFL, ice_shelf_dyn_end, write_ice_shelf_energy +public ice_time_step_CFL, ice_shelf_dyn_end, change_in_draft, write_ice_shelf_energy public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -1091,6 +1091,15 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) endif endif + do j=jsc,jec; do i=isc,iec + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * CS%density_ice + enddo; enddo + + call pass_var(ISS%mass_shelf, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.true.) + !call enable_averages(time_step, Time, CS%diag) !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, ISS%h_shelf, CS%diag) !call disable_averaging(CS%diag) @@ -3171,6 +3180,53 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) end subroutine update_OD_ffrac_uncoupled +subroutine change_in_draft(CS, G, h_shelf0, h_shelf1, ddraft) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf0 !< the previous thickness of the ice shelf [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf1 !< the current thickness of the ice shelf [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: ddraft !< the change in shelf draft thickness + real :: b0,b1 + integer :: i, j, isc, iec, jsc, jec + real :: rhoi_rhow, OD + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + ddraft = 0.0 + + do j=jsc,jec + do i=isc,iec + + b0=0.0; b1=0.0 + + if (h_shelf0(i,j)>0.0) then + OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf0(i,j) + if (OD >= 0) then + !floating + b0 = rhoi_rhow * h_shelf0(i,j) + else + b0 = CS%bed_elev(i,j) + endif + endif + + if (h_shelf1(i,j)>0.0) then + OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf1(i,j) + if (OD >= 0) then + !floating + b1 = rhoi_rhow * h_shelf1(i,j) + else + b1 = CS%bed_elev(i,j) + endif + endif + + ddraft(i,j) = b1-b0 + enddo + enddo +end subroutine change_in_draft + !> This subroutine calculates the gradients of bilinear basis elements that !! that are centered at the vertices of the cell. Values are calculated at !! points of gaussian quadrature. diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 8b66f35f48..e6be780073 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -26,6 +26,7 @@ module MOM_ice_shelf_state area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [L2 ~> m2]. h_shelf => NULL(), & !< the thickness of the shelf [Z ~> m], redundant with mass but may !! make the code more readable + dhdt_shelf => NULL(), & !< the change in thickness of the shelf over time [Z T-1 ~> m s-1] hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells !! 1: fully covered, solve for velocity here (for now all !! ice-covered cells are treated the same, this may change) @@ -70,6 +71,7 @@ subroutine ice_shelf_state_init(ISS, G) allocate(ISS%mass_shelf(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%area_shelf_h(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%h_shelf(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%dhdt_shelf(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%hmask(isd:ied,jsd:jed), source=-2.0 ) allocate(ISS%tflux_ocn(isd:ied,jsd:jed), source=0.0 ) @@ -87,7 +89,7 @@ subroutine ice_shelf_state_end(ISS) if (.not.associated(ISS)) return - deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%hmask) + deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%dhdt_shelf, ISS%hmask) deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf) deallocate(ISS%tfreeze) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 57cddeca5c..b207b1ff1c 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -20,12 +20,12 @@ module MOM_set_visc use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_interface_heights, only : thickness_to_dz -use MOM_io, only : slasher, MOM_read_data +use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS -use MOM_restart, only : register_restart_field_as_obsolete +use MOM_restart, only : register_restart_field_as_obsolete, register_restart_pair use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type @@ -2072,8 +2072,9 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) end subroutine set_viscous_ML !> Register any fields associated with the vertvisc_type. -subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) +subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_CS, use_ice_shelf) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time @@ -2082,6 +2083,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) !! viscosities and related fields. !! Allocated here. type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + logical, intent(in) :: use_ice_shelf !< if true, register tau_shelf restarts ! Local variables logical :: use_kappa_shear, KS_at_vertex logical :: adiabatic, useKPP, useEPBL @@ -2090,6 +2092,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) real :: hfreeze !< If hfreeze > 0 [Z ~> m], melt potential will be computed. character(len=16) :: Kv_units, Kd_units character(len=40) :: mdl = "MOM_set_visc" ! This module's name. + type(vardesc) :: u_desc, v_desc isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & @@ -2173,6 +2176,19 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) conversion=US%Z_to_m**2*US%s_to_T**3) endif + if (use_ice_shelf) then + if (.not.allocated(visc%taux_shelf)) & + allocate(visc%taux_shelf(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%tauy_shelf)) & + allocate(visc%tauy_shelf(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) + u_desc = var_desc("u_taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & + hor_grid='Cu',z_grid='1') + v_desc = var_desc("v_tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & + hor_grid='Cv',z_grid='1') + call register_restart_pair(visc%taux_shelf, visc%tauy_shelf, u_desc, v_desc, & + .false., restart_CS, conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + endif + end subroutine set_visc_register_restarts !> This subroutine does remapping for the auxiliary restart variables in a vertvisc_type From 4329f4709cb9141a5f37dd01d310c8085310e6c9 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 1 Nov 2023 16:15:26 -0400 Subject: [PATCH 135/146] Update makedep to support directory exclusion Makedep can now exclude prescribed directories in the directory tree used to generate the file lists. This is required for projects which may not follow normal development processes, such as the FMS test programs. --- ac/makedep | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/ac/makedep b/ac/makedep index 9da68aa6e6..99c2ef6ce6 100755 --- a/ac/makedep +++ b/ac/makedep @@ -25,12 +25,12 @@ re_procedure = re.compile( ) -def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, +def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, link_externals, script_path): """Create "makefile" after scanning "src_dis".""" # Scan everything Fortran related - all_files = find_files(src_dirs) + all_files = find_files(src_dirs, skip_dirs) # Lists of things # ... all F90 source @@ -332,10 +332,15 @@ def object_file(src_file): return os.path.splitext(os.path.basename(src_file))[0] + '.o' -def find_files(src_dirs): +def find_files(src_dirs, skip_dirs): """Return sorted list of all source files starting from each directory in the list "src_dirs".""" + if skip_dirs is not None: + skip = [os.path.normpath(s) for s in skip_dirs] + else: + skip = [] + # TODO: Make this a user-defined argument extensions = ('.f90', '.f', '.c', '.inc', '.h', '.fh') @@ -345,6 +350,8 @@ def find_files(src_dirs): if not os.path.isdir(path): raise ValueError("Directory '{}' was not found".format(path)) for p, d, f in os.walk(os.path.normpath(path), followlinks=True): + d[:] = [s for s in d if os.path.join(p, s) not in skip] + for file in f: if any(file.lower().endswith(ext) for ext in extensions): files.append(p+'/'+file) @@ -392,8 +399,13 @@ parser.add_argument( action='store_true', help="Annotate the makefile with extra information." ) +parser.add_argument( + '-s', '--skip', + action='append', + help="Skip directory in source code search." +) args = parser.parse_args() # Do the thing -create_deps(args.path, args.makefile, args.debug, args.exec_target, +create_deps(args.path, args.skip, args.makefile, args.debug, args.exec_target, args.fc_rule, args.link_externals, sys.argv[0]) From 4964b8b6a3187fc41aad0814332fe68de8c1fac0 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 3 Nov 2023 11:57:05 -0400 Subject: [PATCH 136/146] Target framework fix; config flag refactor The target (regression) configure step did not use a --with-framework flag and would always build with FMS1, even if FRAMEWORK was set to fms2. This patch adds the flag to its configure step. This patch also does some refactoring of the MOM_ENV and MOM_FCFLAGS setup rules. Values common to all rules are set externally, and additional values for individual rules are appended. Variable syntax also follows Makefile format (spaces around =) rather than POSIX shell (no spaces). --- .testing/Makefile | 50 ++++++++++++++++++++--------------------------- 1 file changed, 21 insertions(+), 29 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 6d2dc2addd..d88008e6f0 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -245,31 +245,26 @@ COV_LDFLAGS := LDFLAGS="$(LDFLAGS_COVERAGE) $(LDFLAGS_DEPS) $(LDFLAGS_USER)" # Environment variable configuration -build/symmetric/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/asymmetric/Makefile: MOM_ENV=$(PATH_FMS) $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) \ +MOM_ENV := $(PATH_FMS) +build/symmetric/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +build/asymmetric/Makefile: MOM_ENV += $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) \ MOM_MEMORY=../../../config_src/memory/dynamic_nonsymmetric/MOM_memory.h -build/repro/Makefile: MOM_ENV=$(PATH_FMS) $(REPRO_FCFLAGS) $(MOM_LDFLAGS) -build/openmp/Makefile: MOM_ENV=$(PATH_FMS) $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) -build/target/Makefile: MOM_ENV=$(PATH_FMS) $(TARGET_FCFLAGS) $(MOM_LDFLAGS) -build/opt/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) -build/opt_target/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) -build/coupled/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/nuopc/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/cov/Makefile: MOM_ENV=$(PATH_FMS) $(COV_FCFLAGS) $(COV_LDFLAGS) -build/unit/Makefile: MOM_ENV=$(PATH_FMS) $(COV_FCFLAGS) $(COV_LDFLAGS) +build/repro/Makefile: MOM_ENV += $(REPRO_FCFLAGS) $(MOM_LDFLAGS) +build/openmp/Makefile: MOM_ENV += $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) +build/target/Makefile: MOM_ENV += $(TARGET_FCFLAGS) $(MOM_LDFLAGS) +build/opt/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +build/opt_target/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +build/coupled/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +build/nuopc/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +build/cov/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +build/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) # Configure script flags -build/symmetric/Makefile: MOM_ACFLAGS= -build/asymmetric/Makefile: MOM_ACFLAGS= -build/repro/Makefile: MOM_ACFLAGS= -build/openmp/Makefile: MOM_ACFLAGS=--enable-openmp -build/target/Makefile: MOM_ACFLAGS= -build/opt/Makefile: MOM_ACFLAGS= -build/opt_target/Makefile: MOM_ACFLAGS= -build/coupled/Makefile: MOM_ACFLAGS=--with-driver=FMS_cap -build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_cap -build/cov/Makefile: MOM_ACFLAGS= -build/unit/Makefile: MOM_ACFLAGS=--with-driver=unit_tests +MOM_ACFLAGS := --with-framework=$(FRAMEWORK) +build/openmp/Makefile: MOM_ACFLAGS += --enable-openmp +build/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap +build/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap +build/unit/Makefile: MOM_ACFLAGS += --with-driver=unit_tests # Fetch regression target source code build/target/Makefile: | $(TARGET_CODEBASE) @@ -277,9 +272,6 @@ build/opt_target/Makefile: | $(TARGET_CODEBASE) # Define source code dependencies -# NOTE: ./configure is too much, but Makefile is not enough! -# Ideally we only want to re-run both Makefile and mkmf, but the mkmf call -# is inside ./configure, so we must re-run ./configure as well. build/target_codebase/configure: $(TARGET_SOURCE) @@ -295,8 +287,8 @@ build/%/MOM6: build/%/Makefile $(MOM_SOURCE) build/%/Makefile: ../ac/configure ../ac/Makefile.in deps/lib/libFMS.a mkdir -p $(@D) cd $(@D) \ - && $(MOM_ENV) ../../../ac/configure $(MOM_ACFLAGS) --with-framework=$(FRAMEWORK) \ - || (cat config.log && false) + && $(MOM_ENV) ../../../ac/configure $(MOM_ACFLAGS) \ + || (cat config.log && false) ../ac/configure: ../ac/configure.ac ../ac/m4 @@ -308,8 +300,8 @@ build/target/Makefile build/opt_target/Makefile: \ $(TARGET_CODEBASE)/ac/configure deps/lib/libFMS.a mkdir -p $(@D) cd $(@D) \ - && $(MOM_ENV) ../../$(TARGET_CODEBASE)/ac/configure $(MOM_ACFLAGS) \ - || (cat config.log && false) + && $(MOM_ENV) ../../$(TARGET_CODEBASE)/ac/configure $(MOM_ACFLAGS) \ + || (cat config.log && false) $(TARGET_CODEBASE)/ac/configure: $(TARGET_CODEBASE) From 715f53ae3a250afe421b02461e62ddba2d5adf44 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 3 Nov 2023 13:29:32 -0400 Subject: [PATCH 137/146] Update default FMS to 2023.03 The default FMS build in ac/deps is updated to 2023.03. FMS source now includes a suite of test programs which require explicit preprocessing macros, which can complicate out makedep-based build when those macros are not present. To avoid this, the new "skip" flag has been added to the makedep build. The skip flag should not cause errors or other issues in older versions of FMS which do not have the excluded directory (though perhaps that could or should change in the future). --- .testing/Makefile | 2 +- ac/deps/Makefile | 2 +- ac/deps/Makefile.fms.in | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index d88008e6f0..6afda40a38 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -75,7 +75,7 @@ MAKEFLAGS += -R -include config.mk # Set the infra framework -FRAMEWORK ?= fms1 +FRAMEWORK ?= fms2 # Set the MPI launcher here # TODO: This needs more automated configuration diff --git a/ac/deps/Makefile b/ac/deps/Makefile index 3263dde678..01431cef8c 100644 --- a/ac/deps/Makefile +++ b/ac/deps/Makefile @@ -8,7 +8,7 @@ MAKEFLAGS += -R # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.03 +FMS_COMMIT ?= 2023.03 # List of source files to link this Makefile's dependencies to model Makefiles diff --git a/ac/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in index caf4abb9c7..71c46f082a 100644 --- a/ac/deps/Makefile.fms.in +++ b/ac/deps/Makefile.fms.in @@ -23,4 +23,4 @@ ARFLAGS = @ARFLAGS@ .PHONY: depend depend: Makefile.dep Makefile.dep: - $(PYTHON) $(MAKEDEP) -o Makefile.dep -e -x libFMS.a @srcdir@ + $(PYTHON) $(MAKEDEP) -o Makefile.dep -e -x libFMS.a -s @srcdir@/test_fms @srcdir@ From feaeb116093cbced4b5384eee3a972db20a9dffe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 11 Oct 2023 17:01:29 -0400 Subject: [PATCH 138/146] *Non-Boussinesq refactoring of brine plumes Revised the recently added brine-plume code to avoid using a vertical sum and to use tv%SpV_avg to determine the brine plume mixing thickness instead of GV%Z_to_H when in non-Boussinesq mode. Several internal brine plume expressions now work in units of H instead of Z, and a total of 5 unit conversion factors were eliminated. This will change certain non-Boussinesq calculations to avoid any dependency on the Boussinesq reference density, but some Boussinesq answers may also be changed and made more robust by avoiding the answer-indeterminate sum() function. --- .../vertical/MOM_diabatic_aux.F90 | 48 +++++++++++++------ 1 file changed, 34 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 95c4d43ad3..6fdfdd5936 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -72,7 +72,8 @@ module MOM_diabatic_aux logical :: do_brine_plume !< If true, insert salt flux below the surface according to !! a parameterization by \cite Nguyen2009. integer :: brine_plume_n !< The exponent in the brine plume parameterization. - real :: plume_strength !< Fraction of the available brine to take to the bottom of the mixed layer. + real :: plume_strength !< Fraction of the available brine to take to the bottom of the mixed + !! layer [nondim]. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output @@ -1093,7 +1094,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 T-3 ~> m2 s-3]. - real, pointer, dimension(:,:), optional :: MLD!< Mixed layer depth for brine plumes [Z ~> m] + real, pointer, dimension(:,:), optional :: MLD !< Mixed layer depth for brine plumes [Z ~> m] ! Local variables integer, parameter :: maxGroundings = 5 @@ -1135,7 +1136,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] netMassInOut_rate, & ! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] - mixing_depth ! Mixed layer depth [Z -> m] + mixing_depth, & ! The mixing depth for brine plumes [H ~> m or kg m-2] + MLD_H, & ! The mixed layer depth for brine plumes in thickness units [H ~> m or kg m-2] + MLD_Z, & ! Running sum of distance from the surface for finding MLD_H [Z ~> m] + total_h ! Total thickness of the water column [H ~> m or kg m-2] real, dimension(SZI_(G), SZK_(GV)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] ! dz, & ! Layer thicknesses in depth units [Z ~> m] @@ -1168,10 +1172,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! and rejected brine are initially applied in vanishingly thin layers at the ! top of the layer before being mixed throughout the layer. logical :: calculate_buoyancy ! If true, calculate the surface buoyancy flux. - real, dimension(SZI_(G)) :: dK ! Depth [Z ~> m]. - real, dimension(SZI_(G)) :: A_brine ! Constant [Z-(n+1) ~> m-(n+1)]. - real :: fraction_left_brine ! Sum for keeping track of the fraction of brine so far (in depth) - real :: plume_fraction ! Sum for keeping track of the fraction of brine so far (in depth) + real :: dK(SZI_(G)) ! Depth of the layer center in thickness units [H ~> m or kg m-2] + real :: A_brine(SZI_(G)) ! Constant [H-(n+1) ~> m-(n+1) or m(2n+2) kg-(n+1)]. + real :: fraction_left_brine ! Fraction of the brine that has not been applied yet [nondim] + real :: plume_fraction ! Fraction of the brine that is applied to a layer [nondim] real :: plume_flux ! Brine flux to move downwards [S H ~> ppt m or ppt kg m-2] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, nb @@ -1238,7 +1242,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP drhodt,drhods,pen_sw_bnd_rate, & !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & !$OMP mixing_depth,A_brine,fraction_left_brine, & - !$OMP plume_fraction,dK) & + !$OMP plume_fraction,dK,MLD_H,MLD_Z,total_h) & !$OMP firstprivate(SurfPressure,plume_flux) do j=js,je ! Work in vertical slices for efficiency @@ -1363,9 +1367,26 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! B/ update mass, salt, temp from mass leaving ocean. ! C/ update temp due to penetrative SW if (CS%do_brine_plume) then + ! Find the plume mixing depth. + if (GV%Boussinesq .or. .not.allocated(tv%SpV_avg)) then + do i=is,ie ; MLD_H(i) = GV%Z_to_H * MLD(i,j) ; total_h(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; total_h(i) = total_h(i) + h(i,j,k) ; enddo ; enddo + else + do i=is,ie ; MLD_H(i) = 0.0 ; MLD_Z(i) = 0.0 ; total_h(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + total_h(i) = total_h(i) + h(i,j,k) + if (MLD_Z(i) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) < MLD(i,j)) then + MLD_H(i) = MLD_H(i) + h(i,j,k) + MLD_Z(i) = MLD_Z(i) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + elseif (MLD_Z(i) < MLD(i,j)) then ! This is the last layer in the mixed layer + MLD_H(i) = MLD_H(i) + GV%RZ_to_H * (MLD(i,j) - MLD_Z(i)) / tv%SpV_avg(i,j,k) + MLD_Z(i) = MLD(i,j) + endif + enddo ; enddo + endif do i=is,ie - mixing_depth(i) = max(MLD(i,j) - minimum_forcing_depth * GV%H_to_Z, minimum_forcing_depth * GV%H_to_Z) - mixing_depth(i) = min(mixing_depth(i), max(sum(h(i,j,:)), GV%angstrom_h) * GV%H_to_Z) + mixing_depth(i) = min( max(MLD_H(i) - minimum_forcing_depth, minimum_forcing_depth), & + max(total_h(i), GV%angstrom_h) ) + GV%H_subroundoff A_brine(i) = (CS%brine_plume_n + 1) / (mixing_depth(i) ** (CS%brine_plume_n + 1)) enddo endif @@ -1464,16 +1485,15 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (fluxes%salt_left_behind(i,j) > 0 .and. fraction_left_brine > 0.0) then ! Place forcing into this layer by depth for brine plume parameterization. if (k == 1) then - dK(i) = 0.5 * h(i,j,k) * GV%H_to_Z ! Depth of center of layer K + dK(i) = 0.5 * h(i,j,k) ! Depth of center of layer K plume_flux = - (1000.0*US%ppt_to_S * (CS%plume_strength * fluxes%salt_left_behind(i,j))) * GV%RZ_to_H plume_fraction = 1.0 else - dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K + dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) ! Depth of center of layer K plume_flux = 0.0 endif if (dK(i) <= mixing_depth(i) .and. fraction_left_brine > 0.0) then - plume_fraction = min(fraction_left_brine, A_brine(i) * dK(i) ** CS%brine_plume_n & - * h(i,j,k) * GV%H_to_Z) + plume_fraction = min(fraction_left_brine, (A_brine(i) * dK(i)**CS%brine_plume_n) * h(i,j,k)) else IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) ! plume_fraction = fraction_left_brine, unless h2d is less than IforcingDepthScale. From 0f2a69d52558d5a44486acdbc83272bd9b451b0c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 8 Nov 2023 09:03:09 -0900 Subject: [PATCH 139/146] Obc tracer fix (#507) * +Fix for issue #506, tracer OBC bug - it only happens in the advection for certain flow directions, inflow from OBC plus along-boundary flow. * Tracer OBCs need more of an h halo update. - This one should finally fix the processor count issues with OBCs. * Correct the "if" statement. * +Adding more halo points to an exchange - This will change answers if you start with a non-zero velocity. You need three halo points (or maybe cont_stencil) for the continuity solver. - Also trying to put in some initial DEBUG_OBC code. * Fix some DEBUG_OBC logic * Writing to temporary arrays for tres_xy - Way to trick some compiler. * Another fix for DEBUG_OBC * Fixing the whalo troubles for grids that are 2 wide/long. * Exchange all the h_new points. - without this, because we're remapping all the tres points, it dies in debug mode on bad h_new values. * Trying a different exchange - as it was, it was passing my tests, failing the auto-tests. * Fixing the DEBUG_OBC logging * Putting the logging statement back. - Making an error more verbose too. --- src/core/MOM.F90 | 12 ++-- src/core/MOM_open_boundary.F90 | 57 ++++++++++++++----- src/framework/MOM_restart.F90 | 4 +- .../lateral/MOM_hor_visc.F90 | 5 +- 4 files changed, 54 insertions(+), 24 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e1fa004fb8..ae794e02e2 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1627,9 +1627,11 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (CS%split) & call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h, h_new, CS%ALE_CSp, CS%OBC, dzRegrid) - if (associated(CS%OBC)) & - call pass_var(h_new, G%Domain) + if (associated(CS%OBC)) then + call pass_var(h, G%Domain, complete=.false.) + call pass_var(h_new, G%Domain, complete=.true.) call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) + endif call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) if (associated(CS%visc%Kv_shear)) & @@ -3016,10 +3018,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call cpu_clock_begin(id_clock_pass_init) call create_group_pass(tmp_pass_uv_T_S_h, CS%u, CS%v, G%Domain) if (use_temperature) then - call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%T, G%Domain, halo=1) - call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%S, G%Domain, halo=1) + call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%T, G%Domain) + call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%S, G%Domain) endif - call create_group_pass(tmp_pass_uv_T_S_h, CS%h, G%Domain, halo=1) + call create_group_pass(tmp_pass_uv_T_S_h, CS%h, G%Domain) call do_group_pass(tmp_pass_uv_T_S_h, G%Domain) call cpu_clock_end(id_clock_pass_init) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 13ce524006..5cf7c92fe9 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -7,33 +7,33 @@ module MOM_open_boundary use MOM_array_transform, only : allocate_rotated_array use MOM_coms, only : sum_across_PEs, Set_PElist, Get_PElist, PE_here, num_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_All, EAST_FACE, NORTH_FACE, SCALAR_PAIR, CGRID_NE, CORNER +use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_grid, only : ocean_grid_type, hor_index_type -use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_interface_heights, only : thickness_to_dz +use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher, field_size, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc +use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char +use MOM_regridding, only : regridding_CS +use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS +use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping use MOM_restart, only : register_restart_field, register_restart_pair use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char -use MOM_string_functions, only : extract_word, remove_spaces, uppercase +use MOM_string_functions, only : extract_word, remove_spaces, uppercase, lowercase use MOM_tidal_forcing, only : astro_longitudes, astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup -use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init -use MOM_interpolate, only : external_field -use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS -use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping -use MOM_regridding, only : regridding_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_string_functions, only : lowercase implicit none ; private @@ -528,13 +528,16 @@ subroutine open_boundary_config(G, US, param_file, OBC) OBC%add_tide_constituents = .false. endif - call get_param(param_file, mdl, "DEBUG", OBC%debug, default=.false.) - call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=.false.) - if (debug_OBC .or. OBC%debug) & + call get_param(param_file, mdl, "DEBUG", debug_OBC, default=.false.) + call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=debug_OBC, & + do_not_log=.not.debug_OBC) + if (debug_OBC) then call log_param(param_file, mdl, "DEBUG_OBC", debug_OBC, & "If true, do additional calls to help debug the performance "//& "of the open boundary condition code.", default=.false., & debuggingParam=.true.) + OBC%debug = debug_OBC + endif call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary "//& @@ -854,6 +857,8 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) ! if (siz(4) == 1) segment%values_needed = .false. if (segment%on_pe) then if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then + write(mesg,'("Brushcutter mode sizes ", I6, I6))') siz(1), siz(2) + call MOM_error(WARNING, mesg // " " // trim(filename) // " " // trim(fieldname)) call MOM_error(FATAL,'segment data are not on the supergrid') endif siz2(1)=1 @@ -2224,6 +2229,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, type(OBC_segment_type), pointer :: segment => NULL() integer :: i, j, k, is, ie, js, je, m, nz, n integer :: is_obc, ie_obc, js_obc, je_obc + logical :: sym + character(len=3) :: var_num is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -3298,6 +3305,29 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, call pass_vector(u_new, v_new, G%Domain, clock=id_clock_pass) + if (OBC%debug) then + sym = G%Domain%symmetric + if (OBC%radiation_BCs_exist_globally) then + call uvchksum("radiation_OBCs: OBC%r[xy]_normal", OBC%rx_normal, OBC%ry_normal, G%HI, & + haloshift=0, symmetric=sym, scale=1.0) + endif + if (OBC%oblique_BCs_exist_globally) then + call uvchksum("radiation_OBCs: OBC%r[xy]_oblique_[uv]", OBC%rx_oblique_u, OBC%ry_oblique_v, G%HI, & + haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + call uvchksum("radiation_OBCs: OBC%r[yx]_oblique_[uv]", OBC%ry_oblique_u, OBC%rx_oblique_v, G%HI, & + haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + call uvchksum("radiation_OBCs: OBC%cff_normal_[uv]", OBC%cff_normal_u, OBC%cff_normal_v, G%HI, & + haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + endif + if (OBC%ntr == 0) return + if (.not. allocated (OBC%tres_x) .or. .not. allocated (OBC%tres_y)) return + do m=1,OBC%ntr + write(var_num,'(I3.3)') m + call uvchksum("radiation_OBCs: OBC%tres_[xy]_"//var_num, OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%HI, & + haloshift=0, symmetric=sym, scale=1.0) + enddo + endif + end subroutine radiation_open_bdry_conds !> Applies OBC values stored in segments to 3d u,v fields @@ -5638,9 +5668,6 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) To_All+Scalar_Pair) if (OBC%oblique_BCs_exist_globally) then call do_group_pass(OBC%pass_oblique, G%Domain) -! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) -! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) -! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) endif end subroutine remap_OBC_fields diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 252f14bfac..188cfbb2ec 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -660,7 +660,7 @@ end subroutine register_restart_field_0d !> query_initialized_name determines whether a named field has been successfully -!! read from a restart file or has otherwise been recored as being initialzed. +!! read from a restart file or has otherwise been recorded as being initialized. function query_initialized_name(name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct @@ -1271,7 +1271,7 @@ subroutine only_read_restart_pair_3d(a_ptr, b_ptr, a_name, b_name, G, CS, & end subroutine only_read_restart_pair_3d -!> Return an indicationof whether the named variable is the restart files, and provie the full path +!> Return an indication of whether the named variable is in the restart files, and provide the full path !! to the restart file in which a variable is found. function find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) result (found) character(len=*), intent(in) :: varname !< The variable name to be used in the restart file diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 02b4ec66a6..e3249afb73 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -414,12 +414,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB h_neglect = GV%H_subroundoff - h_neglect3 = h_neglect**3 + !h_neglect3 = h_neglect**3 + h_neglect3 = h_neglect*h_neglect*h_neglect inv_PI3 = 1.0/((4.0*atan(1.0))**3) inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 - m_leithy(:,:) = 0. ! Initialize + m_leithy(:,:) = 0.0 ! Initialize if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then apply_OBC = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally From b15a9d4deaa73e8272662161e5c2209e8e77de41 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Nov 2023 11:34:59 -0500 Subject: [PATCH 140/146] Adds stand alone test_MOM_EOS and time_MOM_EOS (#516) - Added simple single-thread program to invoke EOS_unit_tests.F90 - Added not-as-simple program to time the cost of calculate_density() and calculate_spec_vol() for both scalar and array APIs - Placed in new directory config_src/drivers/timing_tests/ - Renamed MOM_unit_test_driver.F90 to test_MOM_file_parser.F90 - Updated .testing/Makefile - Added list of programs in config_src/drivers/unit_tests - These are added to BUILDS if DO_UNIT_TESTS is not blank. (DO_UNIT_TESTS was an existing macro but it might be uneeded) - These programs are compiled with code coverage - Added list of programs in config_src/drivers/timing_tests - These programs are compiled with optimization and no coverage - Fixed rule for building UNIT_EXECS (which did not re-build properly because the central Makefile was trying to model the dependencies even though those dependencies are in the build/unit/Makefile.dep) - Added convenient targets build.unit, run.unit, build.timing, run.timing - Timing tests currently time a loop over 1000 calls (so that the resolution of the CPU timer is not too large) and 400 samples to collect statistics on timings. On gaea c5 this takes about 10 seconds. - The results are written to stdout in json. - Added placeholder build and run of timing_tests to GH workflow. - Enabled for [push,pull_request] - We probably will not be able to use timings from GH but I still want to exercise the code we know the timing programs aren't broken by a commit. - Also added driver for string_functions_unit_tests --- .github/workflows/coverage.yml | 12 +- .github/workflows/perfmon.yml | 17 +- .testing/Makefile | 71 ++++-- .testing/README.rst | 11 + .testing/tools/disp_timing.py | 133 +++++++++++ .../drivers/timing_tests/time_MOM_EOS.F90 | 206 ++++++++++++++++++ .../drivers/unit_tests/test_MOM_EOS.F90 | 10 + ...st_driver.F90 => test_MOM_file_parser.F90} | 4 +- .../test_MOM_mixedlayer_restrat.F90 | 10 + .../unit_tests/test_MOM_string_functions.F90 | 10 + src/equation_of_state/MOM_EOS.F90 | 41 +++- src/framework/MOM_error_handler.F90 | 75 +++++-- .../lateral/MOM_mixed_layer_restrat.F90 | 2 + 13 files changed, 564 insertions(+), 38 deletions(-) create mode 100755 .testing/tools/disp_timing.py create mode 100644 config_src/drivers/timing_tests/time_MOM_EOS.F90 create mode 100644 config_src/drivers/unit_tests/test_MOM_EOS.F90 rename config_src/drivers/unit_tests/{MOM_unit_test_driver.F90 => test_MOM_file_parser.F90} (96%) create mode 100644 config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 create mode 100644 config_src/drivers/unit_tests/test_MOM_string_functions.F90 diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index ad15989475..5cd5f91baa 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -19,12 +19,18 @@ jobs: - uses: ./.github/actions/testing-setup - - name: Compile unit testing - run: make -j build/unit/MOM_unit_tests + - name: Compile file parser unit tests + run: make -j build/unit/test_MOM_file_parser - - name: Run unit tests + - name: Run file parser unit tests run: make run.cov.unit + - name: Compile unit testing + run: make -j build.unit + + - name: Run (single processor) unit tests + run: make run.unit + - name: Report unit test coverage to CI (PR) if: github.event_name == 'pull_request' run: make report.cov.unit REQUIRE_COVERAGE_UPLOAD=true diff --git a/.github/workflows/perfmon.yml b/.github/workflows/perfmon.yml index 09b4d617a2..76140c9469 100644 --- a/.github/workflows/perfmon.yml +++ b/.github/workflows/perfmon.yml @@ -1,6 +1,6 @@ name: Performance Monitor -on: [pull_request] +on: [push, pull_request] jobs: build-test-perfmon: @@ -20,6 +20,7 @@ jobs: - uses: ./.github/actions/testing-setup - name: Compile optimized models + if: ${{ github.event_name == 'pull_request' }} run: >- make -j build.prof MOM_TARGET_SLUG=$GITHUB_REPOSITORY @@ -27,12 +28,26 @@ jobs: DO_REGRESSION_TESTS=true - name: Generate profile data + if: ${{ github.event_name == 'pull_request' }} run: >- pip install f90nml && make profile DO_REGRESSION_TESTS=true - name: Generate perf data + if: ${{ github.event_name == 'pull_request' }} run: | sudo sysctl -w kernel.perf_event_paranoid=2 make perf DO_REGRESSION_TESTS=true + + - name: Compile timing tests + run: | + make -j build.timing + + - name: Run timing tests + run: | + make -j run.timing + + - name: Display timing results + run: | + make -j show.timing diff --git a/.testing/Makefile b/.testing/Makefile index 6afda40a38..aabe51c8b6 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -116,6 +116,9 @@ DO_PROFILE ?= # Enable code coverage runs DO_COVERAGE ?= +# Enable code coverage runs +DO_UNIT_TESTS ?= + # Report failure if coverage report is not uploaded REQUIRE_COVERAGE_UPLOAD ?= @@ -151,10 +154,16 @@ ifeq ($(DO_PROFILE), true) BUILDS += opt/MOM6 opt_target/MOM6 endif -# Unit testing -UNIT_EXECS ?= MOM_unit_tests +# Coverage ifeq ($(DO_COVERAGE), true) - BUILDS += cov/MOM6 $(foreach e, $(UNIT_EXECS), unit/$(e)) + BUILDS += cov/MOM6 +endif + +# Unit testing (or coverage) +UNIT_EXECS ?= $(basename $(notdir $(wildcard ../config_src/drivers/unit_tests/*.F90) ) ) +TIMING_EXECS ?= $(basename $(notdir $(wildcard ../config_src/drivers/timing_tests/*.F90) ) ) +ifneq (X$(DO_COVERAGE)$(DO_UNIT_TESTS)X, XX) + BUILDS += $(foreach e, $(UNIT_EXECS), unit/$(e)) endif ifeq ($(DO_PROFILE), false) @@ -258,6 +267,7 @@ build/coupled/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) build/nuopc/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) build/cov/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) build/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +build/timing/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) # Configure script flags MOM_ACFLAGS := --with-framework=$(FRAMEWORK) @@ -265,6 +275,7 @@ build/openmp/Makefile: MOM_ACFLAGS += --enable-openmp build/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap build/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap build/unit/Makefile: MOM_ACFLAGS += --with-driver=unit_tests +build/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests # Fetch regression target source code build/target/Makefile: | $(TARGET_CODEBASE) @@ -276,10 +287,15 @@ build/target_codebase/configure: $(TARGET_SOURCE) # Build executables -$(foreach e,$(UNIT_EXECS),build/unit/$(e)): build/unit/Makefile $(MOM_SOURCE) - cd $(@D) && $(TIME) $(MAKE) -j -build/%/MOM6: build/%/Makefile $(MOM_SOURCE) - cd $(@D) && $(TIME) $(MAKE) -j +build/unit/test_%: build/unit/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -j +build/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) +build/timing/time_%: build/timing/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -j +build/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) +build/%/MOM6: build/%/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -j +FORCE: ; # Use autoconf to construct the Makefile for each target @@ -655,28 +671,47 @@ test.summary: .PHONY: run.cov.unit run.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov -$(WORKSPACE)/work/unit/std.out: build/unit/MOM_unit_tests +.PHONY: build.unit +build.unit: $(foreach f, $(UNIT_EXECS), build/unit/$(f)) +.PHONY: run.unit +run.unit: $(foreach f, $(UNIT_EXECS), work/unit/$(f).out) +.PHONY: build.timing +build.timing: $(foreach f, $(TIMING_EXECS), build/timing/$(f)) +.PHONY: run.timing +run.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).out) +.PHONY: show.timing +show.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).show) +$(WORKSPACE)/work/timing/%.show: + ./tools/disp_timing.py $(@:.show=.out) + +# General rule to run a unit test executable +# Pattern is to run build/unit/executable and direct output to executable.out +$(WORKSPACE)/work/unit/%.out: build/unit/% + @mkdir -p $(@D) + cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> >(tee $*.err) > $*.out + +$(WORKSPACE)/work/unit/test_MOM_file_parser.out: build/unit/test_MOM_file_parser if [ $(REPORT_COVERAGE) ]; then \ find build/unit -name *.gcda -exec rm -f '{}' \; ; \ fi - rm -rf $(@D) mkdir -p $(@D) cd $(@D) \ - && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std.err > std.out \ + && rm -f input.nml logfile.0000*.out *_input MOM_parameter_doc.* \ + && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> test_MOM_file_parser.err > test_MOM_file_parser.out \ || !( \ - cat std.out | tail -n 100 ; \ - cat std.err | tail -n 100 ; \ + cat test_MOM_file_parser.out | tail -n 100 ; \ + cat test_MOM_file_parser.err | tail -n 100 ; \ ) cd $(@D) \ - && $(TIME) $(MPIRUN) -n 2 $(abspath $<) 2> p2.std.err > p2.std.out \ + && $(TIME) $(MPIRUN) -n 2 $(abspath $<) 2> p2.test_MOM_file_parser.err > p2.test_MOM_file_parser.out \ || !( \ - cat p2.std.out | tail -n 100 ; \ - cat p2.std.err | tail -n 100 ; \ + cat p2.test_MOM_file_parser.out | tail -n 100 ; \ + cat p2.test_MOM_file_parser.err | tail -n 100 ; \ ) # NOTE: .gcov actually depends on .gcda, but .gcda is produced with std.out # TODO: Replace $(WORKSPACE)/work/unit/std.out with *.gcda? -build/unit/MOM_file_parser_tests.F90.gcov: $(WORKSPACE)/work/unit/std.out +build/unit/MOM_file_parser_tests.F90.gcov: $(WORKSPACE)/work/unit/test_MOM_file_parser.out cd $(@D) \ && gcov -b *.gcda > gcov.unit.out find $(@D) -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; @@ -693,6 +728,10 @@ report.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov codecov if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ } +$(WORKSPACE)/work/timing/%.out: build/timing/% FORCE + @mkdir -p $(@D) + @echo Running $< in $(@D) + @cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> $*.err > $*.out #--- # Profiling based on FMS clocks diff --git a/.testing/README.rst b/.testing/README.rst index 5bab076707..49103da718 100644 --- a/.testing/README.rst +++ b/.testing/README.rst @@ -22,6 +22,17 @@ Usage ``make clean`` Delete the MOM6 test executables and dependency builds (FMS). +``make -j build.unit`` + Build the unit test programs in config_src/drivers/unit_tests + +``make -j run.unit`` + Run the unit test programs from config_src/drivers/unit_tests in $(WORKSPACE)/work/unit + +``make -j build.timing`` + Build the timing test programs in config_src/drivers/timing_tests + +``make -j run.timing`` + Run the timing test programs from config_src/drivers/timing_tests in $(WORKSPACE)/work/timing Configuration ============= diff --git a/.testing/tools/disp_timing.py b/.testing/tools/disp_timing.py new file mode 100755 index 0000000000..ac90ef2b55 --- /dev/null +++ b/.testing/tools/disp_timing.py @@ -0,0 +1,133 @@ +#!/usr/bin/env python3 + +from __future__ import print_function + +import argparse +import json +import math + +scale = 1e6 # micro-seconds (should make this dynamic) + + +def display_timing_file(file, show_all): + """Parse a JSON file of timing results and pretty-print the results""" + + with open(file) as json_file: + timing_dict = json.load(json_file) + + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Min time Module & function") + for sub in timing_dict.keys(): + tmin = timing_dict[sub]['min'] * scale + print("%10.4e %s" % (tmin, sub)) + + if show_all: + tmean = timing_dict[sub]['mean'] * scale + tmax = timing_dict[sub]['max'] * scale + tstd = timing_dict[sub]['std'] * scale + nsamp = timing_dict[sub]['n_samples'] + tsstd = tstd / math.sqrt(nsamp) + print(" (" + + "mean = %10.4e " % (tmean) + + "±%7.1e, " % (tsstd) + + "max = %10.4e, " % (tmax) + + "std = %8.2e, " % (tstd) + + "# = %d)" % (nsamp)) + + +def compare_timing_files(file, ref, show_all, significance_threshold): + """Read and compare two JSON files of timing results""" + + with open(file) as json_file: + timing_dict = json.load(json_file) + + with open(ref) as json_file: + ref_dict = json.load(json_file) + + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Delta (%) Module & function") + for sub in {**ref_dict, **timing_dict}.keys(): + T1 = ref_dict.get(sub) + T2 = timing_dict.get(sub) + if T1 is not None: + # stats for reference (old) + tmin1 = T1['min'] * scale + tmean1 = T1['mean'] * scale + if T2 is not None: + # stats for reference (old) + tmin2 = T2['min'] * scale + tmean2 = T2['mean'] * scale + if (T1 is not None) and (T2 is not None): + # change in actual minimum as percentage of old + dt = (tmin2 - tmin1) * 100 / tmin1 + if dt < -significance_threshold: + color = '\033[92m' + elif dt > significance_threshold: + color = '\033[91m' + else: + color = '' + print("%s%+10.4f%%\033[0m %s" % (color, dt, sub)) + else: + if T2 is None: + print(" removed %s" % (sub)) + else: + print(" added %s" % (sub)) + + if show_all: + if T2 is None: + print(" --") + else: + tmax2 = T2['max'] * scale + tstd2 = T2['std'] * scale + n2 = T2['n_samples'] + tsstd2 = tstd2 / math.sqrt(n2) + print(" %10.4e (" % (tmin2) + + "mean = %10.4e " % (tmean2) + + "±%7.1e, " % (tsstd2) + + "max=%10.4e, " % (tmax2) + + "std=%8.2e, " % (tstd2) + + "# = %d)" % (n2)) + if T1 is None: + print(" --") + else: + tmax1 = T1['max'] * scale + tstd1 = T1['std'] * scale + n1 = T1['n_samples'] + tsstd1 = tstd1 / math.sqrt(n1) + print(" %10.4e (" % (tmin1) + + "mean = %10.4e " % (tmean1) + + "±%7.1e, " % (tsstd1) + + "max=%10.4e, " % (tmax1) + + "std=%8.2e, " % (tstd1) + + "# = %d)" % (n1)) + + +# Parse arguments +parser = argparse.ArgumentParser( + description="Beautify timing output from MOM6 timing tests." +) +parser.add_argument( + 'file', + help="File to process." +) +parser.add_argument( + '-a', '--all', + action='store_true', + help="Display all metrics rather than just the minimum time." +) +parser.add_argument( + '-t', '--threshold', + default=6.0, type=float, + help="Significance threshold to flag (percentage)." +) +parser.add_argument( + '-r', '--reference', + help="Reference file to compare against." +) +args = parser.parse_args() + +# Do the thing +if args.reference is None: + display_timing_file(args.file, args.all) +else: + compare_timing_files(args.file, args.reference, args.all, args.threshold) diff --git a/config_src/drivers/timing_tests/time_MOM_EOS.F90 b/config_src/drivers/timing_tests/time_MOM_EOS.F90 new file mode 100644 index 0000000000..29bd4a30ab --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_EOS.F90 @@ -0,0 +1,206 @@ +program time_MOM_EOS + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_manual_init +use MOM_EOS, only : calculate_density, calculate_spec_vol +use MOM_EOS, only : list_of_eos, get_EOS_name + +implicit none + +! This macro is used to write out timings of a single test rather than conduct +! a suite of tests. It is not meant for general consumption. +#undef PDF_ONLY + +integer, parameter :: n_fns = 4 +character(len=40) :: fn_labels(n_fns) + +! Testing parameters: +! nic is number of elements to compute density for (array size), per call +! halo is data on either end of the array that should not be used +! nits is how many times to repeat the call between turning the timer on/off +! to overcome limited resolution of the timer +! nsamp repeats the timing to collect statistics on the measurement +#ifdef PDF_ONLY +integer, parameter :: nic=26, halo=4, nits=10000, nsamp=400 +#else +integer, parameter :: nic=23, halo=4, nits=1000, nsamp=400 +#endif + +real :: times(nsamp) ! For observing the PDF + +! Arrays to hold timings: +! first axis corresponds to the form of EOS +! second axis corresponds to the function being timed +real, dimension(:,:), allocatable :: timings, tmean, tstd, tmin, tmax +integer :: n_eos, i, j + +n_eos = size(list_of_eos) +allocate( timings(n_eos,n_fns), tmean(n_eos,n_fns) ) +allocate( tstd(n_eos,n_fns), tmin(n_eos,n_fns), tmax(n_eos,n_fns) ) + +fn_labels(1) = 'calculate_density_scalar()' +fn_labels(2) = 'calculate_density_array()' +fn_labels(3) = 'calculate_spec_vol_scalar()' +fn_labels(4) = 'calculate_spec_vol_array()' + +tmean(:,:) = 0. +tstd(:,:) = 0. +tmin(:,:) = 1.e9 +tmax(:,:) = 0. +do i = 1, nsamp +#ifdef PDF_ONLY + call run_one(list_of_EOS, nic, halo, nits, times(i)) +#else + call run_suite(list_of_EOS, nic, halo, nits, timings) + tmean(:,:) = tmean(:,:) + timings(:,:) + tstd(:,:) = tstd(:,:) + timings(:,:)**2 ! tstd contains sum or squares here + tmin(:,:) = min( tmin(:,:), timings(:,:) ) + tmax(:,:) = max( tmax(:,:), timings(:,:) ) +#endif +enddo +tmean(:,:) = tmean(:,:) / real(nsamp) +tstd(:,:) = tstd(:,:) / real(nsamp) ! convert to mean of squares +tstd(:,:) = tstd(:,:) - tmean(:,:)**2 ! convert to variance +tstd(:,:) = sqrt( tstd(:,:) * ( real(nsamp) / real(nsamp-1) ) ) ! Standard deviation + +#ifdef PDF_ONLY +open(newunit=i, file='times.txt', status='replace', action='write') +write(i,'(1pE9.3)') times(:) +close(i) +#else + +! Display results in YAML +write(*,'(a)') "{" +do i = 1, n_eos + do j = 1, n_fns + write(*,"(2x,5a)") '"MOM_EOS_', trim(get_EOS_name(list_of_EOS(i))), & + ' ', trim(fn_labels(j)), '": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ',tmin(i,j) + write(*,"(4x,a,1pe11.4,',')") '"mean":',tmean(i,j) + write(*,"(4x,a,1pe11.4,',')") '"std": ',tstd(i,j) + write(*,"(4x,a,i7,',')") '"n_samples": ',nsamp + if (i*j.ne.n_eos*n_fns) then + write(*,"(4x,a,1pe11.4,'},')") '"max": ',tmax(i,j) + else + write(*,"(4x,a,1pe11.4,'}')") '"max": ',tmax(i,j) + endif + enddo +enddo +write(*,'(a)') "}" +#endif + +contains + +subroutine run_suite(EOS_list, nic, halo, nits, timings) + integer, intent(in) :: EOS_list(n_eos) !< IDs of EOS forms to loop over + integer, intent(in) :: nic !< Width of computational domain + integer, intent(in) :: halo !< Width of halo to add on either end + integer, intent(in) :: nits !< Number of calls to sample + !! (large enough that the CPU timers can resolve + !! the loop) + real, intent(out) :: timings(n_eos,n_fns) !< The average time taken for nits calls + !! First index corresponds to EOS + !! Second index: 1 = scalar args, + !! 2 = array args without halo, + !! 3 = array args with halo and "dom". + type(EOS_type) :: EOS + integer :: e, i, dom(2) + real :: start, finish, T, S, P, rho + real, dimension(nic+2*halo) :: T1, S1, P1, rho1 + + T = 10. + S = 35. + P = 2000.e4 + + ! Time the scalar interface + do e = 1, n_eos + call EOS_manual_init(EOS, form_of_EOS=EOS_list(e), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits*nic ! Calling nic* to make similar cost to array call + call calculate_density(T, S, P, rho, EOS) + enddo + call cpu_time(finish) + timings(e,1) = (finish - start) / real(nits) + + call cpu_time(start) + do i = 1, nits*nic ! Calling nic* to make similar cost to array call + call calculate_spec_vol(T, S, P, rho, EOS) + enddo + call cpu_time(finish) + timings(e,2) = (finish - start) / real(nits) + + enddo + + ! Time the "dom" interface, 1D array + halos + T1(:) = T + S1(:) = S + P1(:) = P + dom(:) = [1+halo,nic+halo] + + do e = 1, n_eos + call EOS_manual_init(EOS, form_of_EOS=EOS_list(e), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits + call calculate_density(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timings(e,3) = (finish - start) / real(nits) + + call cpu_time(start) + do i = 1, nits + call calculate_spec_vol(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timings(e,4) = (finish - start) / real(nits) + + enddo + +end subroutine run_suite + +!> Return timing for just one fixed call to explore the PDF +subroutine run_one(EOS_list, nic, halo, nits, timing) + integer, intent(in) :: EOS_list(n_eos) !< IDs of EOS forms to loop over + integer, intent(in) :: nic !< Width of computational domain + integer, intent(in) :: halo !< Width of halo to add on either end + integer, intent(in) :: nits !< Number of calls to sample + !! (large enough that the CPU timers can resolve + !! the loop) + real, intent(out) :: timing !< The average time taken for nits calls + !! First index corresponds to EOS + !! Second index: 1 = scalar args, + !! 2 = array args without halo, + !! 3 = array args with halo and "dom". + type(EOS_type) :: EOS + integer :: i, dom(2) + real :: start, finish + real, dimension(nic+2*halo) :: T1, S1, P1, rho1 + + ! Time the scalar interface + call EOS_manual_init(EOS, form_of_EOS=EOS_list(5), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + ! Time the "dom" interface, 1D array + halos + T1(:) = 10. + S1(:) = 35. + P1(:) = 2000.e4 + dom(:) = [1+halo,nic+halo] + + call EOS_manual_init(EOS, form_of_EOS=EOS_list(5), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits + call calculate_density(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timing = (finish-start)/real(nits) + +end subroutine run_one + +end program time_MOM_EOS diff --git a/config_src/drivers/unit_tests/test_MOM_EOS.F90 b/config_src/drivers/unit_tests/test_MOM_EOS.F90 new file mode 100644 index 0000000000..070bec04f6 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_EOS.F90 @@ -0,0 +1,10 @@ +program test_MOM_EOS + +use MOM_EOS, only : EOS_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( EOS_unit_tests(.true.) ) stop 1 + +end program test_MOM_EOS diff --git a/config_src/drivers/unit_tests/MOM_unit_test_driver.F90 b/config_src/drivers/unit_tests/test_MOM_file_parser.F90 similarity index 96% rename from config_src/drivers/unit_tests/MOM_unit_test_driver.F90 rename to config_src/drivers/unit_tests/test_MOM_file_parser.F90 index eafa8fa722..55f57d5fc2 100644 --- a/config_src/drivers/unit_tests/MOM_unit_test_driver.F90 +++ b/config_src/drivers/unit_tests/test_MOM_file_parser.F90 @@ -1,4 +1,4 @@ -program MOM_unit_tests +program test_MOM_file_parser use MPI use MOM_domains, only : MOM_infra_init @@ -62,4 +62,4 @@ program MOM_unit_tests close(io_unit, status='delete') endif -end program MOM_unit_tests +end program test_MOM_file_parser diff --git a/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 new file mode 100644 index 0000000000..3e5eec64fc --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 @@ -0,0 +1,10 @@ +program test_MOM_mixedlayer_restrat + +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( mixedlayer_restrat_unit_tests(.true.) ) stop 1 + +end program test_MOM_mixedlayer_restrat diff --git a/config_src/drivers/unit_tests/test_MOM_string_functions.F90 b/config_src/drivers/unit_tests/test_MOM_string_functions.F90 new file mode 100644 index 0000000000..2376afbbae --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_string_functions.F90 @@ -0,0 +1,10 @@ +program test_MOM_string_functions + +use MOM_string_functions, only : string_functions_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( string_functions_unit_tests(.true.) ) stop 1 + +end program test_MOM_string_functions diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c68dc7b661..2087cd86e5 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -84,6 +84,7 @@ module MOM_EOS public gsw_sp_from_sr public gsw_pt_from_ct public query_compressible +public get_EOS_name ! 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 @@ -181,6 +182,10 @@ module MOM_EOS integer, parameter, public :: EOS_ROQUET_RHO = 7 !< A named integer specifying an equation of state integer, parameter, public :: EOS_ROQUET_SPV = 8 !< A named integer specifying an equation of state integer, parameter, public :: EOS_JACKETT06 = 9 !< A named integer specifying an equation of state +!> A list of all the available EOS +integer, dimension(9), public :: list_of_EOS = (/ EOS_LINEAR, EOS_UNESCO, & + EOS_WRIGHT, EOS_WRIGHT_FULL, EOS_WRIGHT_REDUCED, & + EOS_TEOS10, EOS_ROQUET_RHO, EOS_ROQUET_SPV, EOS_JACKETT06 /) character*(12), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state character*(12), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state @@ -1679,6 +1684,36 @@ logical function query_compressible(EOS) query_compressible = EOS%compressible end function query_compressible +!> Returns the string identifying the equation of state with enumeration "id" +function get_EOS_name(id) result (eos_name) + integer, optional, intent(in) :: id !< Enumerated ID + character(:), allocatable :: eos_name !< The name of the EOS + + select case (id) + case (EOS_LINEAR) + eos_name = EOS_LINEAR_STRING + case (EOS_UNESCO) + eos_name = EOS_UNESCO_STRING + case (EOS_WRIGHT) + eos_name = EOS_WRIGHT_STRING + case (EOS_WRIGHT_REDUCED) + eos_name = EOS_WRIGHT_RED_STRING + case (EOS_WRIGHT_FULL) + eos_name = EOS_WRIGHT_FULL_STRING + case (EOS_TEOS10) + eos_name = EOS_TEOS10_STRING + case (EOS_ROQUET_RHO) + eos_name = EOS_ROQUET_RHO_STRING + case (EOS_ROQUET_SPV) + eos_name = EOS_ROQUET_SPV_STRING + case (EOS_JACKETT06) + eos_name = EOS_JACKETT06_STRING + case default + call MOM_error(FATAL, "get_EOS_name: something went wrong internally - enumeration is not valid.") + end select + +end function get_EOS_name + !> Initializes EOS_type by allocating and reading parameters. The scaling factors in !! US are stored in EOS for later use. subroutine EOS_init(param_file, EOS, US) @@ -2249,7 +2284,11 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "TEOS_POLY TFr has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail - if (verbose .and. .not.EOS_unit_tests) call MOM_mesg("All EOS consistency tests have passed.") + if (EOS_unit_tests) then + call MOM_error(WARNING, "EOS_unit_tests: One or more EOS tests have failed!") + else + if (verbose) call MOM_mesg("EOS_unit_tests: All EOS consistency tests have passed.") + endif end function EOS_unit_tests diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index d61e82b32c..b113050572 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -10,6 +10,11 @@ module MOM_error_handler use posix, only : sigjmp_buf, siglongjmp use posix, only : sleep +! MOM_error_infra does not provide stderr . We only use stderr in this module +! *IF* FMS has not been initialized. Further, stderr is only used internally and +! not made public. Other modules should obtain stderr from MOM_io. +use iso_fortran_env, only : stderr=>error_unit + implicit none ; private ! These routines are found in this module. @@ -20,7 +25,7 @@ module MOM_error_handler public :: is_root_pe, stdlog, stdout !> Integer parameters encoding the severity of an error message public :: NOTE, WARNING, FATAL -public :: disable_fatal_errors, enable_fatal_errors +public :: disable_fatal_errors, enable_fatal_errors, set_skip_mpi integer :: verbosity = 6 !< Verbosity level: @@ -58,6 +63,11 @@ module MOM_error_handler !< The default signal handler used before signal() setup (usually SIG_DFT) type(sigjmp_buf) :: prior_env !< Buffer containing the program state to be recovered by longjmp +logical :: skip_mpi_dep = .false. + !< If true, bypass any calls that require FMS (MPI) to have been initialized. + !! Use s/r set_skip_mpi() to change this flag. By default, set_skip_mpi() does not + !! need to be called and this flag is false so that FMS (and MPI) should be + !! initialized. contains @@ -72,11 +82,15 @@ subroutine MOM_mesg(message, verb, all_print) integer :: verb_msg logical :: write_msg - write_msg = is_root_pe() + if (skip_mpi_dep) then + write_msg = .true. + else + write_msg = is_root_pe() + endif if (present(all_print)) write_msg = write_msg .or. all_print verb_msg = 2 ; if (present(verb)) verb_msg = verb - if (write_msg .and. (verbosity >= verb_msg)) call MOM_err(NOTE, message) + if (write_msg .and. (verbosity >= verb_msg)) call loc_MOM_err(NOTE, message) end subroutine MOM_mesg @@ -121,6 +135,14 @@ subroutine enable_fatal_errors() dummy => signal(sig, prior_handler) end subroutine enable_fatal_errors +!> Enable/disable skipping MPI dependent behaviors +subroutine set_skip_mpi(skip) + logical, intent(in) :: skip !< State to assign + + skip_mpi_dep = skip + +end subroutine set_skip_mpi + !> This provides a convenient interface for writing an error message !! with run-time filter based on a verbosity and the severity of the error. subroutine MOM_error(level, message, all_print) @@ -128,19 +150,21 @@ subroutine MOM_error(level, message, all_print) character(len=*), intent(in) :: message !< A message to write out logical, optional, intent(in) :: all_print !< If present and true, any PEs are !! able to write this message. - ! This provides a convenient interface for writing an error message - ! with run-time filter based on a verbosity. logical :: write_msg integer :: rc - write_msg = is_root_pe() + if (skip_mpi_dep) then + write_msg = .true. + else + write_msg = is_root_pe() + endif if (present(all_print)) write_msg = write_msg .or. all_print select case (level) case (NOTE) - if (write_msg.and.verbosity>=2) call MOM_err(NOTE, message) + if (write_msg.and.verbosity>=2) call loc_MOM_err(NOTE, message) case (WARNING) - if (write_msg.and.verbosity>=1) call MOM_err(WARNING, message) + if (write_msg.and.verbosity>=1) call loc_MOM_err(WARNING, message) case (FATAL) if (ignore_fatal) then print *, "(FATAL): " // message @@ -151,12 +175,33 @@ subroutine MOM_error(level, message, all_print) ! In practice, the signal will take control before sleep() completes. rc = sleep(3) endif - if (verbosity>=0) call MOM_err(FATAL, message) + if (verbosity>=0) call loc_MOM_err(FATAL, message) case default - call MOM_err(level, message) + call loc_MOM_err(level, message) end select end subroutine MOM_error +!> A private routine through which all error/warning/note messages are written +!! by this module. +subroutine loc_MOM_err(level, message) + integer, intent(in) :: level !< The severity level of this message + character(len=*), intent(in) :: message !< A message to write out + + if (.not. skip_mpi_dep) then + call MOM_err(level, message) + else + ! FMS (and therefore MPI) have not been initialized + write(stdout(),'(a)') trim(message) ! Send message to stdout + select case (level) + case (WARNING) + write(stderr,'("WARNING ",a)') trim(message) ! Additionally send message to stderr + case (FATAL) + write(stderr,'("ERROR: ",a)') trim(message) ! Additionally send message to stderr + end select + endif + +end subroutine loc_MOM_err + !> This subroutine sets the level of verbosity filtering MOM error messages subroutine MOM_set_verbosity(verb) integer, intent(in) :: verb !< A level of verbosity to set @@ -202,10 +247,10 @@ subroutine callTree_enter(mesg,n) nAsString = '' if (present(n)) then write(nAsString(1:8),'(i8)') n - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel-1)//'loop '//trim(mesg)//trim(nAsString)) else - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel-1)//'---> '//trim(mesg)) endif endif @@ -217,7 +262,7 @@ subroutine callTree_leave(mesg) if (callTreeIndentLevel<1) write(0,*) 'callTree_leave: error callTreeIndentLevel=',callTreeIndentLevel,trim(mesg) callTreeIndentLevel = callTreeIndentLevel - 1 if (verbosity<6) return - if (is_root_pe()) call MOM_err(NOTE, 'callTree: '// & + if (is_root_pe()) call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'<--- '//trim(mesg)) end subroutine callTree_leave @@ -233,10 +278,10 @@ subroutine callTree_waypoint(mesg,n) nAsString = '' if (present(n)) then write(nAsString(1:8),'(i8)') n - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'loop '//trim(mesg)//trim(nAsString)) else - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'o '//trim(mesg)) endif endif diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 1f73653aa3..e21c33beaf 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1794,6 +1794,8 @@ subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, rest end subroutine mixedlayer_restrat_register_restarts +!> Returns true if a unit test of functions in MOM_mixedlayer_restrat fail. +!! Returns false otherwise. logical function mixedlayer_restrat_unit_tests(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables From 753cab308dc6d87bd17dd4df3f95664158c2deec Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Nov 2023 08:29:43 -0500 Subject: [PATCH 141/146] +Refactor ALE_remap_velocities Refactored ALE_remap_velocities to separate the code setting the thicknesses at velocity points from the code that actually does the remapping. This includes the creation of the new public routines ALE_remap_set_h_vel and ALE_remap_set_h_vel_via_dz and the replacement the pair of tracer point thickness arguments to ALE_remap_velocities and remap_dyn_split_RK2_aux_vars with a pair of the old and new thicknesses at the velocity points and the elimination of several arguments to these routines that are no longer being used. There are also new internal routines ALE_remap_set_h_vel_partial and ALE_remap_set_h_vel_OBC to apply modifications to the velocity point thicknesses with OBCs and one runtime option. The runtime variable REMAP_UV_USING_OLD_ALG has effectively been moved from MOM_ALE.F90 to MOM.F90, although it is still being read in MOM_ALE_init for use with the accelerated regridding during initialization. All answers are bitwise identical, but there are two new public interfaces and changes to the arguments to two other public interfaces and a run-time parameter was moved between modules resulting in changes to some MOM_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 381 +++++++++++++++++++--------- src/core/MOM.F90 | 58 ++++- src/core/MOM_dynamics_split_RK2.F90 | 27 +- 3 files changed, 335 insertions(+), 131 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index e1c8e6911e..77ee1192a2 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -129,6 +129,7 @@ module MOM_ALE public ALE_remap_scalar public ALE_remap_tracers public ALE_remap_velocities +public ALE_remap_set_h_vel, ALE_remap_set_h_vel_via_dz public ALE_remap_interface_vals public ALE_remap_vertex_vals public ALE_PLM_edge_values @@ -597,6 +598,15 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_orig ! The original layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: T ! local temporary temperatures [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: S ! local temporary salinities [S ~> ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: h_old_u ! Source grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: h_old_v ! Source grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: h_new_u ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: h_new_v ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface ! Interface height changes within @@ -607,7 +617,8 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d nz = GV%ke ! initial total interface displacement due to successive regridding - dzIntTotal(:,:,:) = 0. + if (CS%remap_uv_using_old_alg) & + dzIntTotal(:,:,:) = 0. call create_group_pass(pass_T_S_h, T, G%domain) call create_group_pass(pass_T_S_h, S, G%domain) @@ -647,7 +658,8 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d if (allocated(tv_local%SpV_avg)) call calc_derived_thermo(tv_local, h, G, GV, US, halo=1) call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface) - dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) + if (CS%remap_uv_using_old_alg) & + dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) ! remap from original grid onto new grid do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 @@ -663,7 +675,15 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! remap all state variables (including those that weren't needed for regridding) call ALE_remap_tracers(CS, G, GV, h_orig, h, Reg) - call ALE_remap_velocities(CS, G, GV, h_orig, h, u, v, OBC, dzIntTotal) + + call ALE_remap_set_h_vel(CS, G, GV, h_orig, h_old_u, h_old_v, OBC) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS, G, GV, h, h_new_u, h_new_v, OBC, h_orig, dzIntTotal) + else + call ALE_remap_set_h_vel(CS, G, GV, h, h_new_u, h_new_v, OBC) + endif + + call ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v) ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) @@ -808,36 +828,222 @@ subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) end subroutine ALE_remap_tracers -!> This routine remaps velocity components between the old and the new grids, -!! with thicknesses at velocity points taken to be arithmetic averages of tracer thicknesses. -!! This routine may be called during initialization of the model at time=0, to -!! remap initial conditions to the model grid. It is also called during a -!! time step to update the state. -subroutine ALE_remap_velocities(CS, G, GV, h_old, h_new, u, v, OBC, dzInterface, debug, dt) +!> This routine sets the thicknesses at velocity points used for vertical remapping. +subroutine ALE_remap_set_h_vel(CS, G, GV, h_new, h_u, h_v, OBC, debug) + type(ALE_CS), intent(in) :: CS !< ALE 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_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, optional, intent(in) :: debug !< If true, show the call tree + + ! Local variables + logical :: show_call_tree + integer :: i, j, k + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_set_h_vel()") + + ! Build the u- and v-velocity grid thicknesses for remapping. + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_u(I,j,k) = 0.5*(h_new(i,j,k) + h_new(i+1,j,k)) + endif ; enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do k=1,GV%ke ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_v(i,J,k) = 0.5*(h_new(i,j,k) + h_new(i,j+1,k)) + endif ; enddo ; enddo ; enddo + + ! Mask out blocked portions of velocity cells. + if (CS%partial_cell_vel_remap) call ALE_remap_set_h_vel_partial(CS, G, GV, h_new, h_u, h_v) + + ! Take open boundary conditions into account. + if (associated(OBC)) call ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + + if (show_call_tree) call callTree_leave("ALE_remap_set_h_vel()") + +end subroutine ALE_remap_set_h_vel + +!> This routine sets the thicknesses at velocity points used for vertical remapping using a +!! combination of the old grid and interface movements. +subroutine ALE_remap_set_h_vel_via_dz(CS, G, GV, h_new, h_u, h_v, OBC, h_old, dzInterface, debug) type(ALE_CS), intent(in) :: CS !< ALE 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_old !< Thickness of source grid - !! [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid - !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Thickness of source grid when generating + !! the destination grid via the old + !! algorithm [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: dzInterface !< Change in interface position + intent(in) :: dzInterface !< Change in interface position !! [H ~> m or kg m-2] - logical, optional, intent(in) :: debug !< If true, show the call tree - real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] + logical, optional, intent(in) :: debug !< If true, show the call tree + ! Local variables + logical :: show_call_tree + integer :: i, j, k + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_set_h_vel()") + + ! Build the u- and v-velocity grid thicknesses for remapping using the old grid and interface movement. + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_u(I,j,k) = max( 0., 0.5*(h_old(i,j,k) + h_old(i+1,j,k)) + & + 0.5 * (( dzInterface(i,j,k) + dzInterface(i+1,j,k) ) - & + ( dzInterface(i,j,k+1) + dzInterface(i+1,j,k+1) )) ) + endif ; enddo ; enddo ; enddo + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_v(i,J,k) = max( 0., 0.5*(h_old(i,j,k) + h_old(i,j+1,k)) + & + 0.5 * (( dzInterface(i,j,k) + dzInterface(i,j+1,k) ) - & + ( dzInterface(i,j,k+1) + dzInterface(i,j+1,k+1) )) ) + endif ; enddo ; enddo ; enddo + + ! Mask out blocked portions of velocity cells. + if (CS%partial_cell_vel_remap) call ALE_remap_set_h_vel_partial(CS, G, GV, h_old, h_u, h_v) + + ! Take open boundary conditions into account. + if (associated(OBC)) call ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + + if (show_call_tree) call callTree_leave("ALE_remap_set_h_vel()") + +end subroutine ALE_remap_set_h_vel_via_dz + +!> Mask out the thicknesses at velocity points where they are below the minimum depth +!! at adjacent tracer points +subroutine ALE_remap_set_h_vel_partial(CS, G, GV, h_mask, h_u, h_v) + type(ALE_CS), intent(in) :: CS !< ALE 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_mask !< Thickness at tracer points + !! used to apply the partial + !! cell masking [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: h_tot ! The vertically summed thicknesses [H ~> m or kg m-2] real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] - real, dimension(GV%ke+1) :: dz ! The change in interface heights interpolated to - ! a velocity point [H ~> m or kg m-2] - logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. + integer :: i, j, k + + h_tot(:,:) = 0.0 + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + h_tot(i,j) = h_tot(i,j) + h_mask(i,j,k) + enddo ; enddo ; enddo + + !$OMP parallel do default(shared) private(h_mask_vel) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_mask_vel = min(h_tot(i,j), h_tot(i+1,j)) + call apply_partial_cell_mask(h_u(I,j,:), h_mask_vel) + endif ; enddo ; enddo + + !$OMP parallel do default(shared) private(h_mask_vel) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_mask_vel = min(h_tot(i,j), h_tot(i,j+1)) + call apply_partial_cell_mask(h_v(i,J,:), h_mask_vel) + endif ; enddo ; enddo + +end subroutine ALE_remap_set_h_vel_partial + +! Reset thicknesses at velocity points on open boundary condition segments +subroutine ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + 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_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + ! Local variables + integer :: i, j, k, nz + + if (.not.associated(OBC)) return + + nz = GV%ke + + ! Take open boundary conditions into account. + !$OMP parallel do default(shared) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do k=1,nz ; h_u(I,j,k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + do k=1,nz ; h_u(I,j,k) = h_new(i+1,j,k) ; enddo + endif + endif ; enddo ; enddo + + !$OMP parallel do default(shared) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do k=1,nz ; h_v(i,J,k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + do k=1,nz ; h_v(i,J,k) = h_new(i,j+1,k) ; enddo + endif + endif ; enddo ; enddo + +end subroutine ALE_remap_set_h_vel_OBC + +!> This routine remaps velocity components between the old and the new grids, +!! with thicknesses at velocity points taken to be arithmetic averages of tracer thicknesses. +!! This routine may be called during initialization of the model at time=0, to +!! remap initial conditions to the model grid. It is also called during a +!! time step to update the state. +subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, debug) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + logical, optional, intent(in) :: debug !< If true, show the call tree + + ! Local variables + real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] real :: u_src(GV%ke) ! A column of u-velocities on the source grid [L T-1 ~> m s-1] real :: u_tgt(GV%ke) ! A column of u-velocities on the target grid [L T-1 ~> m s-1] real :: v_src(GV%ke) ! A column of v-velocities on the source grid [L T-1 ~> m s-1] @@ -852,11 +1058,6 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old, h_new, u, v, OBC, dzInterface, if (present(debug)) show_call_tree = debug if (show_call_tree) call callTree_enter("ALE_remap_velocities()") - ! If remap_uv_using_old_alg is .true. and u or v is requested, then we must have dzInterface. Otherwise, - ! u and v can be remapped without dzInterface - if (CS%remap_uv_using_old_alg .and. .not.present(dzInterface) ) call MOM_error(FATAL, & - "ALE_remap_velocities: dzInterface must be present if using old algorithm.") - if (CS%answer_date >= 20190101) then h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff elseif (GV%Boussinesq) then @@ -867,107 +1068,55 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old, h_new, u, v, OBC, dzInterface, nz = GV%ke - if (CS%partial_cell_vel_remap) then - h_tot(:,:) = 0.0 - do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - h_tot(i,j) = h_tot(i,j) + h_old(i,j,k) - enddo ; enddo ; enddo - endif + ! --- Remap u profiles from the source vertical grid onto the new target grid. - ! Remap u velocity component - if ( .true. ) then - - !$OMP parallel do default(shared) private(h1,h2,dz,u_src,h_mask_vel,u_tgt) - do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then - ! Build the start and final grids - do k=1,nz - h1(k) = 0.5*(h_old(i,j,k) + h_old(i+1,j,k)) - h2(k) = 0.5*(h_new(i,j,k) + h_new(i+1,j,k)) - enddo - if (CS%remap_uv_using_old_alg) then - dz(:) = 0.5 * ( dzInterface(i,j,:) + dzInterface(i+1,j,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dz(k) - dz(k+1) ) ) - enddo - endif + !$OMP parallel do default(shared) private(h1,h2,u_src,h_mask_vel,u_tgt) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + ! Make a 1-d copy of the start and final grids and the source velocity + do k=1,nz + h1(k) = h_old_u(I,j,k) + h2(k) = h_new_u(I,j,k) + u_src(k) = u(I,j,k) + enddo - if (CS%partial_cell_vel_remap) then - h_mask_vel = min(h_tot(i,j), h_tot(i+1,j)) - call apply_partial_cell_mask(h1, h_mask_vel) - call apply_partial_cell_mask(h2, h_mask_vel) - endif + call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & + h_neglect, h_neglect_edge) - if (associated(OBC)) then ; if (OBC%segnum_u(I,j) /= 0) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do k=1,nz ; h1(k) = h_old(i,j,k) ; h2(k) = h_new(i,j,k) ; enddo - else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) - do k=1,nz ; h1(k) = h_old(i+1,j,k) ; h2(k) = h_new(i+1,j,k) ; enddo - endif - endif ; endif + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) & + call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) - ! --- Remap u profiles from the source vertical grid onto the new target grid. - do k=1,nz - u_src(k) = u(I,j,k) - enddo - call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & - h_neglect, h_neglect_edge) + ! Copy the column of new velocities back to the 3-d array + do k=1,nz + u(I,j,k) = u_tgt(k) + enddo !k + endif ; enddo ; enddo - if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then - call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) - endif + if (show_call_tree) call callTree_waypoint("u remapped (ALE_remap_velocities)") - do k=1,nz - u(I,j,k) = u_tgt(k) - enddo !k - endif ; enddo ; enddo - endif - if (show_call_tree) call callTree_waypoint("u remapped (ALE_remap_velocities)") + ! --- Remap v profiles from the source vertical grid onto the new target grid. - ! Remap v velocity component - if ( .true. ) then - !$OMP parallel do default(shared) private(h1,h2,v_src,dz,h_mask_vel,v_tgt) - do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then - ! Build the start and final grids - do k=1,nz - h1(k) = 0.5*(h_old(i,j,k) + h_old(i,j+1,k)) - h2(k) = 0.5*(h_new(i,j,k) + h_new(i,j+1,k)) - enddo - if (CS%remap_uv_using_old_alg) then - dz(:) = 0.5 * ( dzInterface(i,j,:) + dzInterface(i,j+1,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dz(k) - dz(k+1) ) ) - enddo - endif - if (CS%partial_cell_vel_remap) then - h_mask_vel = min(h_tot(i,j), h_tot(i,j+1)) - call apply_partial_cell_mask(h1, h_mask_vel) - call apply_partial_cell_mask(h2, h_mask_vel) - endif - if (associated(OBC)) then ; if (OBC%segnum_v(i,J) /= 0) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do k=1,nz ; h1(k) = h_old(i,j,k) ; h2(k) = h_new(i,j,k) ; enddo - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - do k=1,nz ; h1(k) = h_old(i,j+1,k) ; h2(k) = h_new(i,j+1,k) ; enddo - endif - endif ; endif + !$OMP parallel do default(shared) private(h1,h2,v_src,h_mask_vel,v_tgt) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then - ! --- Remap v profiles from the source vertical grid onto the new target grid. - do k=1,nz - v_src(k) = v(i,J,k) - enddo - call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & - h_neglect, h_neglect_edge) + do k=1,nz + h1(k) = h_old_v(i,J,k) + h2(k) = h_new_v(i,J,k) + v_src(k) = v(i,J,k) + enddo - if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then - call mask_near_bottom_vel(v_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) - endif + call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & + h_neglect, h_neglect_edge) - do k=1,nz - v(i,J,k) = v_tgt(k) - enddo !k - endif ; enddo ; enddo - endif + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then + call mask_near_bottom_vel(v_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) + endif + + ! Copy the column of new velocities back to the 3-d array + do k=1,nz + v(i,J,k) = v_tgt(k) + enddo !k + endif ; enddo ; enddo if (show_call_tree) call callTree_waypoint("v remapped (ALE_remap_velocities)") if (show_call_tree) call callTree_leave("ALE_remap_velocities()") diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ae794e02e2..bcba4d37c7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -54,6 +54,7 @@ module MOM use MOM_ALE, only : ALE_getCoordinate, ALE_getCoordinateUnits, ALE_writeCoordinateFile use MOM_ALE, only : ALE_updateVerticalGridType, ALE_remap_init_conds, pre_ALE_adjustments use MOM_ALE, only : ALE_remap_tracers, ALE_remap_velocities +use MOM_ALE, only : ALE_remap_set_h_vel, ALE_remap_set_h_vel_via_dz use MOM_ALE, only : ALE_update_regrid_weights, pre_ALE_diagnostics, ALE_register_diags use MOM_ALE_sponge, only : rotate_ALE_sponge, update_ALE_sponge_field use MOM_barotropic, only : Barotropic_CS @@ -253,6 +254,8 @@ module MOM logical :: remap_aux_vars !< If true, apply ALE remapping to all of the auxiliary 3-D !! variables that are needed to reproduce across restarts, !! similarly to what is done with the primary state variables. + logical :: remap_uv_using_old_alg !< If true, use the old "remapping via a delta z" method for + !! velocities. If false, remap between two grids described by thicknesses. type(MOM_stoch_eos_CS) :: stoch_eos_CS !< structure containing random pattern for stoch EOS logical :: alternate_first_direction !< If true, alternate whether the x- or y-direction @@ -1499,6 +1502,14 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & real :: h_new(SZI_(G),SZJ_(G),SZK_(GV)) ! Layer thicknesses after regridding [H ~> m or kg m-2] real :: dzRegrid(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The change in grid interface positions due to regridding, ! in the same units as thicknesses [H ~> m or kg m-2] + real :: h_old_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! Source grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real :: h_old_v(SZI_(G),SZJB_(G),SZK_(GV)) ! Source grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + real :: h_new_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real :: h_new_v(SZI_(G),SZJB_(G),SZK_(GV)) ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] logical :: PCM_cell(SZI_(G),SZJ_(G),SZK_(GV)) ! If true, PCM remapping should be used in a cell. logical :: use_ice_shelf ! Needed for selecting the right ALE interface. logical :: showCallTree @@ -1620,12 +1631,23 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (showCallTree) call callTree_waypoint("new grid generated") ! Remap all variables from the old grid h onto the new grid h_new call ALE_remap_tracers(CS%ALE_CSp, G, GV, h, h_new, CS%tracer_Reg, showCallTree, dtdia, PCM_cell) - call ALE_remap_velocities(CS%ALE_CSp, G, GV, h, h_new, u, v, CS%OBC, dzRegrid, showCallTree, dtdia) + + ! Determine the old and new grid thicknesses at velocity points. + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h, h_old_u, h_old_v, CS%OBC, debug=showCallTree) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, h, dzRegrid, showCallTree) + else + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, debug=showCallTree) + endif + + ! Remap the velocity components. + call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, showCallTree) + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. if (CS%remap_aux_vars) then if (CS%split) & - call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h, h_new, CS%ALE_CSp, CS%OBC, dzRegrid) + call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h_old_u, h_old_v, h_new_u, h_new_v, CS%ALE_CSp) if (associated(CS%OBC)) then call pass_var(h, G%Domain, complete=.false.) @@ -2025,6 +2047,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & real, allocatable, dimension(:,:,:) :: h_new ! Layer thicknesses after regridding [H ~> m or kg m-2] real, allocatable, dimension(:,:,:) :: dzRegrid ! The change in grid interface positions due to regridding, ! in the same units as thicknesses [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_old_u ! Source grid thickness at zonal velocity points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_old_v ! Source grid thickness at meridional velocity + ! points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_new_u ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_new_v ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] logical, allocatable, dimension(:,:,:) :: PCM_cell ! If true, PCM remapping should be used in a cell. type(group_pass_type) :: tmp_pass_uv_T_S_h, pass_uv_T_S_h @@ -2197,6 +2226,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(param_file, "MOM", "REMAP_UV_USING_OLD_ALG", CS%remap_uv_using_old_alg, & + "If true, uses the old remapping-via-a-delta-z method for "//& + "remapping u and v. If false, uses the new method that remaps "//& + "between grids described by an old and new thickness.", & + default=.false., do_not_log=.not.CS%use_ALE_algorithm) call get_param(param_file, "MOM", "REMAP_AUXILIARY_VARS", CS%remap_aux_vars, & "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& "variables that are needed to reproduce across restarts, similarly to "//& @@ -2996,6 +3030,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & allocate(h_new(isd:ied, jsd:jed, nz), source=0.0) allocate(dzRegrid(isd:ied, jsd:jed, nz+1), source=0.0) allocate(PCM_cell(isd:ied, jsd:jed, nz), source=.false.) + allocate(h_old_u(IsdB:IedB, jsd:jed, nz), source=0.0) + allocate(h_new_u(IsdB:IedB, jsd:jed, nz), source=0.0) + allocate(h_old_v(isd:ied, JsdB:JedB, nz), source=0.0) + allocate(h_new_v(isd:ied, JsdB:JedB, nz), source=0.0) if (use_ice_shelf) then call ALE_regrid(G, GV, US, CS%h, h_new, dzRegrid, CS%tv, CS%ALE_CSp, CS%frac_shelf_h, PCM_cell) else @@ -3005,7 +3043,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (callTree_showQuery()) call callTree_waypoint("new grid generated") ! Remap all variables from the old grid h onto the new grid h_new call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, CS%debug, PCM_cell=PCM_cell) - call ALE_remap_velocities(CS%ALE_CSp, G, GV, CS%h, h_new, CS%u, CS%v, CS%OBC, dzRegrid, debug=CS%debug) + + ! Determine the old and new grid thicknesses at velocity points. + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, CS%h, h_old_u, h_old_v, CS%OBC, debug=CS%debug) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, CS%h, dzRegrid, CS%debug) + else + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, debug=CS%debug) + endif + + ! Remap the velocity components. + call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u, CS%v, CS%debug) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. ! Replace the old grid with new one. All remapping must be done at this point. @@ -3013,7 +3062,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 CS%h(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo - deallocate(h_new, dzRegrid, PCM_cell) + + deallocate(h_new, dzRegrid, PCM_cell, h_old_u, h_new_u, h_old_v, h_new_v) call cpu_clock_begin(id_clock_pass_init) call create_group_pass(tmp_pass_uv_T_S_h, CS%u, CS%v, G%Domain) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 36ba8b60f8..debc63cb46 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1261,29 +1261,34 @@ end subroutine register_restarts_dyn_split_RK2 !> This subroutine does remapping for the auxiliary restart variables that are used !! with the split RK2 time stepping scheme. -subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old, h_new, ALE_CSp, OBC, dzRegrid) +subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h_new_v, ALE_CSp) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping - type(ocean_OBC_type), pointer :: OBC !< OBC control structure to use when remapping - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: dzRegrid !< Change in interface position [H ~> m or kg m-2] if (.not.CS%remap_aux) return if (CS%store_CAu) then - call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%u_av, CS%v_av, OBC, dzRegrid) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u_av, CS%v_av) call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) - call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%CAu_pred, CS%CAv_pred, OBC, dzRegrid) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%CAu_pred, CS%CAv_pred) call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.true.) endif - call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%diffu, CS%diffv, OBC, dzRegrid) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%diffu, CS%diffv) end subroutine remap_dyn_split_RK2_aux_vars From cce4b3da5e26b3ee2cae6e683988410340abad1b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 8 Nov 2023 18:04:32 -0500 Subject: [PATCH 142/146] Fix a bug that left OBC%debug uninitialized This commit fixes a bug to ensure that OBC%debug is always being set when OBCs are in use. After a recent commit, the value of OBC%debug was not being set and was being left in an indeterminate whenever DEBUG_OBC=False or DEBUG=False and DEBUG_OBC was unspecified. This would lead to the model writing out a number of checksums in some cases with open boundary conditions enabled, depending on what value was inherited by the uninitialized OBC%debug. Although this does not change any answers, it will avoid a problem that will write out a large volume of undesired output and greatly slow down configurations with open boundary conditions. --- src/core/MOM_open_boundary.F90 | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 5cf7c92fe9..7bfb6479b2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -426,7 +426,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) ! Local variables integer :: l ! For looping over segments - logical :: debug_OBC, mask_outside, reentrant_x, reentrant_y + logical :: debug, debug_OBC, mask_outside, reentrant_x, reentrant_y character(len=15) :: segment_param_str ! The run-time parameter name for each segment character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG @@ -528,25 +528,22 @@ subroutine open_boundary_config(G, US, param_file, OBC) OBC%add_tide_constituents = .false. endif - call get_param(param_file, mdl, "DEBUG", debug_OBC, default=.false.) - call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=debug_OBC, & - do_not_log=.not.debug_OBC) - if (debug_OBC) then - call log_param(param_file, mdl, "DEBUG_OBC", debug_OBC, & + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + ! This extra get_param call is to enable logging if either DEBUG or DEBUG_OBC are true. + call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=debug) + call get_param(param_file, mdl, "DEBUG_OBC", OBC%debug, & "If true, do additional calls to help debug the performance "//& - "of the open boundary condition code.", default=.false., & - debuggingParam=.true.) - OBC%debug = debug_OBC - endif + "of the open boundary condition code.", & + default=debug, do_not_log=.not.(debug_OBC.or.debug), debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary "//& "conditions for debugging.", units="m", default=0.0, scale=US%m_to_Z, & - do_not_log=.not.debug_OBC, debuggingParam=.true.) + do_not_log=.not.OBC%debug, debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & "A silly value of velocities used outside of open boundary "//& "conditions for debugging.", units="m/s", default=0.0, scale=US%m_s_to_L_T, & - do_not_log=.not.debug_OBC, debuggingParam=.true.) + do_not_log=.not.OBC%debug, debuggingParam=.true.) reentrant_x = .false. call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) reentrant_y = .false. From f4c95ec4b81e2958c151be101d2b15b0de28f910 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 14 Nov 2023 20:38:01 -0500 Subject: [PATCH 143/146] Revert post_data fix to CFC concentration The most recent NCAR -> GFDL merge created an error (courtesy of myself) which left the CFC concentration units in the post_data call, even though these are now handled at registration. This patch restores this expression and removes the unit conversion from post_data. --- src/tracer/MOM_CFC_cap.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 38777346a1..16506b41c3 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -404,8 +404,7 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! If needed, write out any desired diagnostics from tracer sources & sinks here. do m=1,NTR if (CS%CFC_data(m)%id_cmor > 0) & - call post_data(CS%CFC_data(m)%id_cmor, & - (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(m)%conc, CS%diag) + call post_data(CS%CFC_data(m)%id_cmor, CS%CFC_data(m)%conc, CS%diag) if (CS%CFC_data(m)%id_sfc_flux > 0) & call post_data(CS%CFC_data(m)%id_sfc_flux, CS%CFC_data(m)%sfc_flux, CS%diag) From 7ef6a57252ba9132496b4e67aafa09d47fe7eafd Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 21 Nov 2023 12:05:19 -0900 Subject: [PATCH 144/146] Fix the saltFluxAdded diagnoistic, broken in #401 --- src/core/MOM_forcing_type.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index dcbf440292..b8b3174b4a 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -361,6 +361,7 @@ module MOM_forcing_type integer :: id_saltflux = -1 integer :: id_saltFluxIn = -1 integer :: id_saltFluxAdded = -1 + integer :: id_saltFluxBehind = -1 integer :: id_total_saltflux = -1 integer :: id_total_saltFluxIn = -1 @@ -2099,7 +2100,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, diag%axesT1,Time,'Salt flux into ocean at surface due to restoring or flux adjustment', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) - handles%id_saltFluxAdded = register_diag_field('ocean_model', 'salt_left_behind', & + handles%id_saltFluxBehind = register_diag_field('ocean_model', 'salt_left_behind', & diag%axesT1,Time,'Salt left in ocean at surface due to ice formation', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) @@ -3130,6 +3131,9 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_saltFluxIn, total_transport, diag) endif + if (handles%id_saltFluxBehind > 0 .and. associated(fluxes%salt_left_behind)) & + call post_data(handles%id_saltFluxBehind, fluxes%salt_left_behind, diag) + if (handles%id_saltFluxGlobalAdj > 0) & call post_data(handles%id_saltFluxGlobalAdj, fluxes%saltFluxGlobalAdj, diag) if (handles%id_vPrecGlobalAdj > 0) & From 40134ed86a10b0616134bdaef653d37f2616e873 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Mon, 4 Dec 2023 13:41:27 -0500 Subject: [PATCH 145/146] change target to pointer and check for association --- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 4 ++-- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index c404e94459..3de5ad1162 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2052,7 +2052,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output. type(set_diffusivity_CS), pointer :: CS !< pointer set to point to the module control !! structure. - type(int_tide_CS), intent(in), target :: int_tide_CSp !< Internal tide control structure + type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure integer, intent(out) :: halo_TS !< The halo size of tracer points that must be !! valid for the calculations in set_diffusivity. logical, intent(out) :: double_diffuse !< This indicates whether some version @@ -2097,7 +2097,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed CS%diag => diag - CS%int_tide_CSp => int_tide_CSp + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp ! These default values always need to be set. CS%BBL_mixing_as_max = .true. diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 6e53679549..31f90cdcb1 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -221,7 +221,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di 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 !< Run-time parameter file handle - type(int_tide_CS),target, intent(in) :: int_tide_CSp !< A pointer to the internal tides control structure + type(int_tide_CS), pointer :: int_tide_CSp !< A pointer to the internal tides control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure. @@ -276,7 +276,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%debug = CS%debug.and.is_root_pe() CS%diag => diag - CS%int_tide_CSp => int_tide_CSp + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp CS%use_CVmix_tidal = use_CVmix_tidal CS%int_tide_dissipation = int_tide_dissipation From 6d7c00a837c0d038beec3a61627221a4863bc47e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 22 Feb 2024 13:11:05 -0500 Subject: [PATCH 146/146] Restore bit repro using FMA in selected runs This patch modifies select calculations of PR#1616 in order to preserve bit reproducibility when FMA optimization is enabled. We add parentheses and reorder terms in selected expressions which either direct or suppress FMAs, ensuring equivalence with the previous release. We address two specific equations in the PR. The first is associated with vertical friction coupling coupling coefficient. The diff is shown below. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear*GV%H_to_Z + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) The denominator is of the form `a*b + c*d`. A compiler may favor an FMA of the form `a*b + (c*d)`. However, the modified equation is of form which favors the `a + c*d` FMA. Each form gives different results in the final bits. We resolve this by expliciting wrapping the RHS in parentheses: a_cpl(i,K) = Kv_tot(i,K) / (h_shear + (I_amax*Kv_tot(i,K))) Although this disables the FMA, it produces the same bit-equivalent answer as the original expression. ---- The second equation for TKE due to kappa shear is shown below. - tke_src = dz_Int(K) *(((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & - (TKE(k) - q0)*TKE_decay(k)) - & + tke_src = h_Int(K) * (dz_h_Int(K)*((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & + (TKE(k) - q0)*TKE_decay(k)) - & ... The outer equation was of the form `b + c` but is promoted to `a*b + c`, transforming it to an FMA. We resolve this by suppressing this FMA optimization: tke_src = h_Int(K) * ((dz_h_Int(K) * ((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K))) - & (TKE(k) - q0)*TKE_decay(k)) - & ... ---- The following two changes are intended to be the smallest modification which preserves answers for known testing on target compilers. It does not encompass all equation changes in this PR. If needed, we could extend these changes to similar modifications of PR#1616. We do not expect to support bit reproducibility when FMAs are enabled. But this is an ongoing conversation, and the rules around FMAs should be expected to change as we learn more and agree on rules of reproducibility. --- src/parameterizations/vertical/MOM_kappa_shear.F90 | 2 +- src/parameterizations/vertical/MOM_vert_friction.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 81ab0661cc..8a1974d8ea 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -1618,7 +1618,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, h_Int, dz_Int, dz_h_Int, I_L2_b ! Solve for dQ(K)... aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) dQdz(k) = 0.5*(TKE(K) - TKE(K+1))*Idz(k) - tke_src = h_Int(K) * (dz_h_Int(K)*((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & + tke_src = h_Int(K) * ((dz_h_Int(K) * ((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K))) - & (TKE(k) - q0)*TKE_decay(k)) - & (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 8d41fcb63a..ead2cf00cf 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2116,7 +2116,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + (I_amax * Kv_tot(i,K))) endif ; enddo ; enddo ! i & k loops elseif (abs(CS%Kv_extra_bbl) > 0.0) then ! There is a simple enhancement of the near-bottom viscosities, but no adjustment