From 3f61c034c2542355d640f1007669e2cf8516b1ec Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 31 Mar 2022 15:56:51 -0500 Subject: [PATCH 01/10] Add a deta_dt diagnostic to the split BT/BC mode The SSH tendency can now be computed for the split baroclinic/ bartropic (integrated with RK2) way of calculating the dynamics. This extra diagnostic is needed for computing vertical mass transport (wmo) in z* coordinates offline from the convergence of the horizontal mass transports. The meaning, units, and conversion factors associated with the deta_dt diagnostic change between Boussinesq and non-Boussinesq modes. This commit accounts for these differences and reports the units consistent with the mass transports. --- src/core/MOM_dynamics_split_RK2.F90 | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index d177e63be8..b01c462480 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -177,6 +177,7 @@ module MOM_dynamics_split_RK2 integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 integer :: id_intz_CAu_2d = -1, id_intz_CAv_2d = -1 integer :: id_CAu_visc_rem = -1, id_CAv_visc_rem = -1 + integer :: id_deta_dt = -1 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 @@ -315,6 +316,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: eta_pred + real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! eta_pred is the predictor value of the free surface height or column mass, ! [H ~> m or kg m-2]. @@ -347,6 +349,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s h_av ! The layer thickness time-averaged over a time step [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 logical :: dyn_p_surf logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the @@ -357,10 +360,13 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: cont_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 u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta + Idt_bc = 1./dt + sym=.false.;if (G%Domain%symmetric) sym=.true. ! switch to include symmetric domain in checksums showCallTree = callTree_showQuery() @@ -760,6 +766,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s 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, & 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 + endif do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo call cpu_clock_end(id_clock_btstep) @@ -958,6 +967,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_v_BT_accel_visc_rem > 0) & call post_product_v(CS%id_v_BT_accel_visc_rem, CS%v_accel_bt, CS%ADp%visc_rem_v, G, nz, CS%diag) + ! Diagnostics related to changes in eta + if (CS%id_deta_dt > 0) call post_data(CS%id_deta_dt, deta_dt, CS%diag) + if (CS%debug) then call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -1334,6 +1346,14 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & x_cell_method='sum', v_extensive = .true.) + if (GV%Boussinesq) then + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic SSH tendency due to dynamics', trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T) + else + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic column-mass tendency due to dynamics', trim(thickness_units)//' s-1', & + conversion=GV%H_to_mks*US%s_to_T) + endif !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', & From 764ea05d51f383120e70a06a6436a42a06cb2449 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Apr 2022 10:37:59 -0400 Subject: [PATCH 02/10] +Add Hybgen regridding This commit adds the ability to use Hybgen regridding, derived from Hycom code. There are two new files, MOM_hybgen_regrid.F90 and MOM_hybgen_unmix.F90, which in turn add 15 new runtime parameters (with names like HYBGEN_...) to control the hybgen code. This new regridding option is specified via REGRIDDING_COORDINATE_MODE="HYBGEN", and this new option is listed in the MOM_parameter_doc files for cases that have USE_REGRIDDING=True. There is also a new publicly visible parameter, REGRIDDING_HYBGEN, in regrid_consts.F90. In addition, the new routine regridding_preadjust_reqs is provided in MOM_regridding to specify whether convective adjustment or hybgen_unmixing should be done before regridding. This is used along with the optional argument conv_adjust to regridding_main to move these pre-adjustment steps out of regridding_main. The unused routine ALE_build_grid was eliminated, and comments were added describing a few undocumented internal real variables. All answers are bitwise identical, but there are several new public interfaces and there will be new lines in the comments in some MOM_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 103 +- src/ALE/MOM_hybgen_regrid.F90 | 983 ++++++++++++++++++ src/ALE/MOM_hybgen_unmix.F90 | 502 +++++++++ src/ALE/MOM_regridding.F90 | 97 +- src/ALE/regrid_consts.F90 | 5 + .../MOM_state_initialization.F90 | 39 +- 6 files changed, 1646 insertions(+), 83 deletions(-) create mode 100644 src/ALE/MOM_hybgen_regrid.F90 create mode 100644 src/ALE/MOM_hybgen_unmix.F90 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index fa195d57eb..97303aa100 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -20,6 +20,8 @@ module MOM_ALE use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_error_handler, only : callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +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_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W @@ -27,6 +29,7 @@ module MOM_ALE use MOM_regridding, only : initialize_regridding, regridding_main, end_regridding use MOM_regridding, only : uniformResolution use MOM_regridding, only : inflate_vanished_layers_old +use MOM_regridding, only : regridding_preadjust_reqs, convective_adjustment use MOM_regridding, only : set_target_densities_from_GV, set_target_densities use MOM_regridding, only : regriddingCoordinateModeDoc, DEFAULT_COORDINATE_MODE use MOM_regridding, only : regriddingInterpSchemeDoc, regriddingDefaultInterpScheme @@ -73,6 +76,11 @@ module MOM_ALE type(remapping_CS) :: remapCS !< Remapping parameters and work arrays type(remapping_CS) :: vel_remapCS !< Remapping parameters for velocities and work arrays + type(hybgen_unmix_CS), pointer :: hybgen_unmixCS => NULL() !< Parameters for hybgen remapping + + logical :: use_hybgen_unmix !< If true, use the hybgen unmixing code before regridding + logical :: do_conv_adj !< If true, do convective adjustment before regridding + integer :: nk !< Used only for queries, not directly by this module real :: BBL_h_vel_mask !< The thickness of a bottom boundary layer within which velocities in !! thin layers are zeroed out after remapping, following practice with @@ -119,7 +127,6 @@ module MOM_ALE public ALE_main_offline public ALE_offline_inputs public ALE_offline_tracer_final -public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar public ALE_PLM_edge_values @@ -165,6 +172,8 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) logical :: force_bounds_in_subcell logical :: local_logical logical :: remap_boundary_extrap + type(hybgen_regrid_CS), pointer :: hybgen_regridCS => NULL() ! Control structure for hybgen regridding + ! for sharing parameters. if (associated(CS)) then call MOM_error(WARNING, "ALE_init called with an associated "// & @@ -184,6 +193,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) ! Initialize and configure regridding call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS) + call regridding_preadjust_reqs(CS%regridCS, CS%do_conv_adj, CS%use_hybgen_unmix, hybgen_CS=hybgen_regridCS) ! Initialize and configure remapping that is orchestrated by ALE. call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & @@ -277,6 +287,9 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "to avoid such filtering altogether.", & default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=(CS%BBL_h_vel_mask<=0.0)) + if (CS%use_hybgen_unmix) & + call init_hybgen_unmix(CS%hybgen_unmixCS, GV, US, param_file, hybgen_regridCS) + call get_param(param_file, "MOM", "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) @@ -350,6 +363,7 @@ subroutine ALE_end(CS) ! Deallocate memory used for the regridding call end_remapping( CS%remapCS ) + if (CS%use_hybgen_unmix) call end_hybgen_unmix( CS%hybgen_unmixCS ) call end_regridding( CS%regridCS ) deallocate(CS) @@ -379,9 +393,9 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta_preale real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [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. - integer :: nk, i, j, k, isc, iec, jsc, jec, ntr + integer :: ntr, i, j, k, isc, iec, jsc, jec, nk - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke if (CS%show_call_tree) call callTree_enter("ALE_main(), MOM_ALE.F90") @@ -401,10 +415,19 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) endif dzRegrid(:,:,:) = 0.0 + ! If necessary, do some preparatory work to clean up the model state before regridding. + + ! This adjusts the input thicknesses prior to remapping, based on the verical coordinate. + if (CS%do_conv_adj) call convective_adjustment(G, GV, h, tv) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, G%US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + ! Build new grid. The new grid is stored in h_new. The old grid is h. ! Both are needed for the subsequent remapping of variables. call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, & - frac_shelf_h, PCM_cell=PCM_cell) + frac_shelf_h, conv_adjust=.false., PCM_cell=PCM_cell) call check_grid( G, GV, h, 0. ) @@ -459,9 +482,9 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg m-2] - integer :: nk, i, j, k, isc, iec, jsc, jec + integer :: ntr, i, j, k, isc, iec, jsc, jec, nk - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke if (CS%show_call_tree) call callTree_enter("ALE_main_offline(), MOM_ALE.F90") @@ -470,9 +493,16 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) endif dzRegrid(:,:,:) = 0.0 + ! This adjusts the input state prior to remapping, depending on the verical coordinate. + if (CS%do_conv_adj) call convective_adjustment(G, GV, h, tv) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, G%US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + ! Build new grid. The new grid is stored in h_new. The old grid is h. ! Both are needed for the subsequent remapping of variables. - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid ) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust=.false. ) call check_grid( G, GV, h, 0. ) @@ -519,7 +549,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) real, dimension(SZK_(GV)) :: h_dest ! Destination grid thicknesses at velocity points [H ~> m or kg m-2] real, dimension(SZK_(GV)) :: temp_vec ! Transports on the destination grid [H L2 ~> m3 or kg] - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke dzRegrid(:,:,:) = 0.0 h_new(:,:,:) = 0.0 @@ -595,13 +625,18 @@ subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS, OBC) real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid !< The change in grid interface positions real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new !< Regridded target thicknesses - integer :: nk, i, j, k, isc, iec, jsc, jec + integer :: ntr, i, j, k, isc, iec, jsc, jec, nk - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke if (CS%show_call_tree) call callTree_enter("ALE_offline_tracer_final(), MOM_ALE.F90") ! Need to make sure that h_target is consistent with the current offline ALE confiuration - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h_target, tv, h_new, dzRegrid ) + if (CS%do_conv_adj) call convective_adjustment(G, GV, h_target, tv) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, G%US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h_target, tv, h_new, dzRegrid, conv_adjust=.false. ) call check_grid( G, GV, h_target, 0. ) @@ -651,52 +686,17 @@ subroutine check_grid( G, GV, h, threshold ) end subroutine check_grid -!### This routine does not appear to be used. -!> Generates new grid -subroutine ALE_build_grid( G, GV, regridCS, remapCS, h, tv, debug, frac_shelf_h ) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(regridding_CS), intent(in) :: regridCS !< Regridding parameters and options - type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variable structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the - !! last time step [H ~> m or kg m-2] - logical, optional, intent(in) :: debug !< If true, show the call tree - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in):: frac_shelf_h !< Fractional ice shelf coverage [nondim] - ! Local variables - integer :: nk, i, j, k - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new ! The new grid thicknesses - logical :: show_call_tree - - show_call_tree = .false. - if (present(debug)) show_call_tree = debug - if (show_call_tree) call callTree_enter("ALE_build_grid(), MOM_ALE.F90") - - ! Build new grid. The new grid is stored in h_new. The old grid is h. - ! Both are needed for the subsequent remapping of variables. - call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h ) - - ! Override old grid with new one. The new grid 'h_new' is built in - ! one of the 'build_...' routines above. -!$OMP parallel do default(none) shared(G,h,h_new) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) h(i,j,:) = h_new(i,j,:) - enddo ; enddo - - if (show_call_tree) call callTree_leave("ALE_build_grid()") -end subroutine ALE_build_grid !> 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, u, v, OBC, Reg, dt, dzRegrid, initial) +subroutine ALE_regrid_accelerated(CS, G, GV, 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 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) - integer, intent(in) :: n !< Number of times to regrid + integer, intent(in) :: n_itt !< Number of times to regrid 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)), & @@ -711,7 +711,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg !! routine (and expect diagnostics to work) ! Local variables - integer :: i, j, k, nz + integer :: i, j, itt, nz type(thermo_var_ptrs) :: tv_local ! local/intermediate temp/salt type(group_pass_type) :: pass_T_S_h ! group pass if the coordinate has a stencil real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc, h_orig ! A working copy of layer thicknesses @@ -744,11 +744,12 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg if (present(dt)) & call ALE_update_regrid_weights(dt, CS) - do k = 1, n + do itt = 1, n_itt call do_group_pass(pass_T_S_h, G%domain) ! generate new grid - call regridding_main(CS%remapCS, CS%regridCS, G, GV, h_loc, tv_local, h, dzInterface) + 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, conv_adjust=.false.) 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 new file mode 100644 index 0000000000..783820829f --- /dev/null +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -0,0 +1,983 @@ +!> This module contains the hybgen regridding routines from HYCOM, with minor +!! modifications to follow the MOM6 coding conventions +module MOM_hybgen_regrid + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type, calculate_density +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, assert +use MOM_file_parser, only : get_param, param_file_type, log_param +use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists +use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE +use MOM_string_functions, only : slasher +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!> Control structure containing required parameters for the hybgen coordinate generator +type, public :: hybgen_regrid_CS ; private + + real :: min_thickness !< Minimum thickness allowed for layers [H ~> m or kg m-2] + + integer :: nk !< Number of layers on the target grid + + !> Reference pressure for density calculations [R L2 T-2 ~> Pa] + real :: ref_pressure + + !> Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + real :: hybiso + !> Number of sigma levels used by HYBGEN + integer :: nsigma + + real :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real :: qhybrlx !< Fractional relaxation within a regridding step [nondim] + + real, allocatable, dimension(:) :: & + dp0k, & !< minimum deep z-layer separation [H ~> m or kg m-2] + ds0k !< minimum shallow z-layer separation [H ~> m or kg m-2] + + real :: coord_scale = 1.0 !< A scaling factor to restores the depth coordinates to values in m + real :: Rho_coord_scale = 1.0 !< A scaling factor to restores the denesity coordinates to values in kg m-3 + + real :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real :: min_dilate !< The minimum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when wetting occurs. + real :: max_dilate !< The maximum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when drying occurs. + + real :: thkbot !< Thickness of a bottom boundary layer, within which hybgen does + !! something different. [H ~> m or kg m-2] + + !> Shallowest depth for isopycnal layers [H ~> m or kg m-2] + real :: topiso_const + ! real, dimension(:,:), allocatable :: topiso + + !> 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] + +end type hybgen_regrid_CS + + +public hybgen_regrid, init_hybgen_regrid, end_hybgen_regrid +public hybgen_column_init, get_hybgen_regrid_params, write_Hybgen_coord_file + +contains + +!> Initialise a hybgen_regrid_CS control structure and store its parameters +subroutine init_hybgen_regrid(CS, GV, US, param_file) + type(hybgen_regrid_CS), pointer :: CS !< Unassociated pointer to hold the control 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 + + character(len=40) :: mdl = "MOM_hybgen_regrid" ! This module's name. + real :: hybrlx ! The number of remappings over which to move toward the target coordinate [timesteps] + character(len=40) :: dp0_coord_var, ds0_coord_var, rho_coord_var + character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + logical :: use_coord_file + integer :: k + + if (associated(CS)) call MOM_error(FATAL, "init_hybgen_regrid: CS already associated!") + allocate(CS) + + CS%nk = GV%ke + + allocate(CS%target_density(CS%nk)) + allocate(CS%dp0k(CS%nk), source=0.0) ! minimum deep z-layer separation + allocate(CS%ds0k(CS%nk), source=0.0) ! minimum shallow z-layer separation + + do k=1,CS%nk ; CS%target_density(k) = GV%Rlay(k) ; enddo + + call get_param(param_file, mdl, "P_REF", CS%ref_pressure, & + "The pressure that is used for calculating the coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & + units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + + call get_param(param_file, mdl, "HYBGEN_MIN_THICKNESS", CS%min_thickness, & + "The minimum layer thickness allowed when regridding with Hybgen.", & + units="m", default=0.0, scale=GV%m_to_H ) + + call get_param(param_file, mdl, "HYBGEN_N_SIGMA", CS%nsigma, & + "The number of sigma-coordinate (terrain-following) layers with Hybgen regridding.", & + default=0) + call get_param(param_file, mdl, "HYBGEN_COORD_FILE", coord_file, & + "The file from which the Hybgen profile is read, or blank to use a list of "//& + "real input parameters from the MOM_input file.", default="") + + use_coord_file = (len_trim(coord_file) > 0) + call get_param(param_file, mdl, "HYBGEN_DEEP_DZ_PR0FILE", CS%dp0k, & + "The layerwise list of deep z-level minimum thicknesses for Hybgen (dp0k in Hycom).", & + units="m", default=0.0, scale=GV%m_to_H, do_not_log=use_coord_file) + call get_param(param_file, mdl, "HYBGEN_SHALLOW_DZ_PR0FILE", CS%ds0k, & + "The layerwise list of shallow z-level minimum thicknesses for Hybgen (ds0k in Hycom).", & + units="m", default=0.0, scale=GV%m_to_H, do_not_log=use_coord_file) + + if (use_coord_file) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + filename = trim(inputdir)//trim(coord_file) + call log_param(param_file, mdl, "INPUTDIR/HYBGEN_COORD_FILE", filename) + if (.not.file_exists(filename)) call MOM_error(FATAL, & + " set_coord_from_file: Unable to open "//trim(filename)) + + call get_param(param_file, mdl, "HYBGEN_DEEP_DZ_VAR", dp0_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the "//& + "deep z-level minimum thicknesses for Hybgen (dp0k in Hycom).", & + default="dp0") + call get_param(param_file, mdl, "HYBGEN_SHALLOW_DZ_VAR", ds0_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the "//& + "shallow z-level minimum thicknesses for Hybgen (ds0k in Hycom).", & + default="ds0") + call get_param(param_file, mdl, "HYBGEN_TGT_DENSITY_VAR", rho_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the Hybgen "//& + "target layer densities, or blank to reuse the values in GV%Rlay.", & + default="") + + call MOM_read_data(filename, dp0_coord_var, CS%dp0k, scale=GV%m_to_H) + + call MOM_read_data(filename, ds0_coord_var, CS%ds0k, scale=GV%m_to_H) + + if (len_trim(rho_coord_var) > 0) & + call MOM_read_data(filename, rho_coord_var, CS%target_density, scale=US%kg_m3_to_R) + endif + + call get_param(param_file, mdl, "HYBGEN_ISOPYCNAL_DZ_MIN", CS%dp00i, & + "The Hybgen deep isopycnal spacing minimum thickness (dp00i in Hycom)", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_MIN_ISO_DEPTH", CS%topiso_const, & + "The Hybgen shallowest depth for isopycnal layers (isotop in Hycom)", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_RELAX_PERIOD", hybrlx, & + "The Hybgen coordinate relaxation period in timesteps, or 1 to move to "//& + "the new target coordinates in a single step. This must be >= 1.", & + units="timesteps", default=1.0) + if (hybrlx < 1.0) call MOM_error(FATAL, "init_hybgen_regrid: HYBGEN_RELAX_PERIOD must be at least 1.") + CS%qhybrlx = 1.0 / hybrlx + call get_param(param_file, mdl, "HYBGEN_BBL_THICKNESS", CS%thkbot, & + "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_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.", & + units="kg m-3", default=0.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "HYBGEN_REMAP_MIN_ZSTAR_DILATE", CS%min_dilate, & + "The maximum amount of dilation that is permitted when converting target "//& + "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & + default=0.5) + call get_param(param_file, mdl, "HYBGEN_REMAP_MAX_ZSTAR_DILATE", CS%max_dilate, & + "The maximum amount of dilation that is permitted when converting target "//& + "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & + default=2.0) + + CS%onem = 1.0 * GV%m_to_H + + do k=1,CS%nk ; CS%dp0k(k) = max(CS%dp0k(k), CS%min_thickness) ; enddo + CS%dp00i = max(CS%dp00i, CS%min_thickness) + + ! Determine the depth range over which to use a sigma (terrain-following) coordinate. + ! --- terrain following starts at depth dpns and ends at depth dsns + if (CS%nsigma == 0) then + CS%dpns = CS%dp0k(1) + CS%dsns = 0.0 + else + CS%dpns = 0.0 + CS%dsns = 0.0 + do k=1,CS%nsigma + CS%dpns = CS%dpns + CS%dp0k(k) + CS%dsns = CS%dsns + CS%ds0k(k) + enddo !k + endif !nsigma + + CS%coord_scale = GV%H_to_m + CS%Rho_coord_scale = US%R_to_kg_m3 + +end subroutine init_hybgen_regrid + +!> Writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model. +subroutine write_Hybgen_coord_file(GV, CS, filepath) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(hybgen_regrid_CS), intent(in) :: CS !< Control structure for this module + character(len=*), intent(in) :: filepath !< The full path to the file to write + ! Local variables + type(vardesc) :: vars(3) + type(fieldtype) :: fields(3) + type(file_type) :: IO_handle ! The I/O handle of the fileset + + vars(1) = var_desc("dp0", "meter", "Deep z-level minimum thicknesses for Hybgen", '1', 'L', '1') + vars(2) = var_desc("ds0", "meter", "Shallow z-level minimum thicknesses for Hybgen", '1', 'L', '1') + vars(3) = var_desc("Rho_tgt", "kg m-3", "Target coordinate potential densities for Hybgen", '1', 'L', '1') + call create_file(IO_handle, trim(filepath), vars, 3, fields, SINGLE_FILE, GV=GV) + + call MOM_write_field(IO_handle, fields(1), CS%dp0k, scale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(2), CS%ds0k, scale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(3), CS%target_density, scale=CS%Rho_coord_scale) + + call close_file(IO_handle) + +end subroutine write_Hybgen_coord_file + +!> This subroutine deallocates memory in the control structure for the hybgen module +subroutine end_hybgen_regrid(CS) + type(hybgen_regrid_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + + deallocate(CS%target_density) + deallocate(CS%dp0k, CS%ds0k) + deallocate(CS) +end subroutine end_hybgen_regrid + +!> This subroutine can be used to retrieve the parameters for the hybgen regrid module +subroutine get_hybgen_regrid_params(CS, nk, ref_pressure, hybiso, nsigma, dp00i, qhybrlx, & + dp0k, ds0k, dpns, dsns, min_dilate, max_dilate, & + thkbot, topiso_const, target_density) + type(hybgen_regrid_CS), pointer :: CS !< Coordinate regridding control structure + integer, optional, intent(out) :: nk !< Number of layers on the target grid + real, optional, intent(out) :: ref_pressure !< Reference pressure for density calculations [R L2 T-2 ~> Pa] + real, optional, intent(out) :: hybiso !< Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + integer, optional, intent(out) :: nsigma !< Number of sigma levels used by HYBGEN + real, optional, intent(out) :: dp00i !< Deep isopycnal spacing minimum thickness (m) + real, optional, intent(out) :: qhybrlx !< Fractional relaxation amount per timestep, 0 < qyhbrlx <= 1 [nondim] + real, optional, intent(out) :: dp0k(:) !< minimum deep z-layer separation [H ~> m or kg m-2] + real, optional, intent(out) :: ds0k(:) !< minimum shallow z-layer separation [H ~> m or kg m-2] + real, optional, intent(out) :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real, optional, intent(out) :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real, optional, intent(out) :: min_dilate !< The minimum amount of dilation that is permitted when + !! converting target coordinates from z to z* [nondim]. + !! This limit applies when wetting occurs. + real, optional, intent(out) :: max_dilate !< The maximum amount of dilation that is permitted when + !! converting target coordinates from z to z* [nondim]. + !! This limit applies when drying occurs. + real, optional, intent(out) :: thkbot !< Thickness of a bottom boundary layer, within which + !! hybgen does something different. [H ~> m or kg m-2] + real, optional, intent(out) :: topiso_const !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + ! real, dimension(:,:), allocatable :: topiso + real, optional, intent(out) :: target_density(:) !< Nominal density of interfaces [R ~> kg m-3] + + if (.not. associated(CS)) call MOM_error(FATAL, "get_hybgen_params: CS not associated") + + if (present(nk)) nk = CS%nk + if (present(ref_pressure)) ref_pressure = CS%ref_pressure + if (present(hybiso)) hybiso = CS%hybiso + if (present(nsigma)) nsigma = CS%nsigma + if (present(dp00i)) dp00i = CS%dp00i + if (present(qhybrlx)) qhybrlx = CS%qhybrlx + if (present(dp0k)) then + if (size(dp0k) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The dp0k argument is not allocated with enough space.") + dp0k(1:CS%nk) = CS%dp0k(1:CS%nk) + endif + if (present(ds0k)) then + if (size(ds0k) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The ds0k argument is not allocated with enough space.") + ds0k(1:CS%nk) = CS%ds0k(1:CS%nk) + endif + if (present(dpns)) dpns = CS%dpns + if (present(dsns)) dsns = CS%dsns + if (present(min_dilate)) min_dilate = CS%min_dilate + if (present(max_dilate)) max_dilate = CS%max_dilate + if (present(thkbot)) thkbot = CS%thkbot + if (present(topiso_const)) topiso_const = CS%topiso_const + if (present(target_density)) then + if (size(target_density) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The target_density argument is not allocated with enough space.") + target_density(1:CS%nk) = CS%target_density(1:CS%nk) + endif + +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) + 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] + 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), & + intent(inout) :: dzInterface !< The change in height of each interface, + !! using a sign convention opposite to the change + !! in pressure [H ~> m or kg m-2] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: PCM_cell !< If true, PCM remapping should be used in a cell. + !! This is effectively intent out, but values in wide + !! halo regions and land points are reused. + + ! --- ------------------------------------- + ! --- hybrid grid generator from HYCOM + ! --- ------------------------------------- + + ! These notes on the parameters for the hybrid grid generator are inhereted from the + ! Hycom source code for these algorithms. + ! + ! From blkdat.input (units may have changed from m to pressure): + ! + ! --- 'nsigma' = number of sigma levels + ! --- 'dp0k ' = layer k deep z-level spacing minimum thickness (m) + ! --- k=1,nk + ! --- 'ds0k ' = layer k shallow z-level spacing minimum thickness (m) + ! --- k=1,nsigma + ! --- 'dp00i' = deep isopycnal spacing minimum thickness (m) + ! --- 'isotop' = shallowest depth for isopycnal layers (m) + ! now in topiso(:,:) + ! --- 'sigma ' = isopycnal layer target densities (sigma units) + ! --- now in theta(:,:,1:nk) + ! + ! --- the above specifies a vertical coord. that is isopycnal or: + ! --- near surface z in deep water, based on dp0k + ! --- near surface z in shallow water, based on ds0k and nsigma + ! --- terrain-following between them, based on ds0k and nsigma + ! + ! --- terrain following starts at depth dpns=sum(dp0k(k),k=1,nsigma) and + ! --- ends at depth dsns=sum(ds0k(k),k=1,nsigma), and the depth of the + ! --- k-th layer interface varies linearly with total depth between + ! --- these two reference depths, i.e. a z-sigma-z fixed coordinate. + ! + ! --- near the surface (i.e. shallower than isotop), layers are always + ! --- fixed depth (z or sigma). + ! -- layer 1 is always fixed, so isotop=0.0 is not realizable. + ! --- near surface layers can also be forced to be fixed depth + ! --- by setting target densities (sigma(k)) very small. + ! + ! --- away from the surface, the minimum layer thickness is dp00i. + ! + ! --- for fixed depth targets to be: + ! --- z-only set nsigma=0, + ! --- sigma-z (shallow-deep) use a very small ds0k(:), + ! --- sigma-only set nsigma=nk, dp0k large, and ds0k small. + + ! These arrays work with the input column + real :: p_col(GV%ke) ! A column of reference pressures [R L2 T-2 ~> Pa] + real :: temp_in(GV%ke) ! A column of input potential temperatures [degC] + real :: saln_in(GV%ke) ! A column of input layer salinities [ppt] + real :: Rcv_in(GV%ke) ! An input column of coordinate potential density [R ~> kg m-3] + real :: dp_in(GV%ke) ! The input column of layer thicknesses [H ~> m or kg m-2] + logical :: PCM_lay(GV%ke) ! If true for a layer, use PCM remapping for that layer + + ! These arrays are on the target grid. + real :: Rcv_tgt(CS%nk) ! Target potential density [R ~> kg m-3] + real :: Rcv(CS%nk) ! Initial values of coordinate potential density on the target grid [R ~> kg m-3] + real :: h_col(CS%nk) ! A column of layer thicknesses [H ~> m or kg m-2] + real :: dz_int(CS%nk+1) ! The change in interface height due to remapping [H ~> m or kg m-2] + real :: Rcv_integral ! Integrated coordinate potential density in a layer [R H ~> kg m-2 or kg2 m-5] + + real :: qhrlx(CS%nk+1) ! Fractional relaxation within a timestep (between 0 and 1) [nondim] + real :: dp0ij(CS%nk) ! minimum layer thickness [H ~> m or kg m-2] + real :: dp0cum(CS%nk+1) ! minimum interface depth [H ~> m or kg m-2] + + 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 :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] + integer :: fixlay ! Deepest fixed coordinate layer + integer, dimension(0:CS%nk) :: k_end ! The index of the deepest source layer that contributes to + ! each target layer, in the unusual case where the the input grid is + ! larger than the new grid. This situation only occurs during certain + ! types of initialization or when generating output diagnostics. + integer :: i, j, k, nk, m, k2, nk_in + + nk = CS%nk + + 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 + + ! Store one-dimensional arrays of thicknesses for the 'old' vertical grid before regridding + h_tot = 0.0 + do K=1,GV%ke + temp_in(k) = tv%T(i,j,k) + saln_in(k) = tv%S(i,j,k) + dp_in(k) = dp(i,j,k) + h_tot = h_tot + dp_in(k) + enddo + + ! This sets the input column's coordinate potential density from T and S. + call calculate_density(temp_in, saln_in, p_col, Rcv_in, tv%eqn_of_state) + + ! Set the initial properties on the new grid from the old grid. + nk_in = GV%ke + if (GV%ke > CS%nk) then ; do k=GV%ke,CS%nk+1,-1 + ! Remove any excess massless layers from the bottom of the input column. + if (dp_in(k) > 0.0) exit + nk_in = k-1 + enddo ; endif + + if (CS%nk >= nk_in) then + ! Simply copy over the common layers. This is the usual case. + do k=1,min(CS%nk,GV%ke) + h_col(k) = dp_in(k) + Rcv(k) = Rcv_in(k) + enddo + if (CS%nk > GV%ke) then + ! Pad out the input column with additional massless layers with the bottom properties. + ! This case only occurs during initialization or perhaps when writing diagnostics. + do k=GV%ke+1,CS%nk + Rcv(k) = Rcv_in(GV%ke) + h_col(k) = 0.0 + enddo + endif + else ! (CS%nk < nk_in) + ! The input column has more data than the output. For now, combine layers to + ! make them the same size, but there may be better approaches that should be taken. + ! This case only occurs during initialization or perhaps when writing diagnostics. + ! This case was not handled by the original Hycom code in hybgen.F90. + do k=0,CS%nk ; k_end(k) = (k * nk_in) / CS%nk ; enddo + do k=1,CS%nk + h_col(k) = 0.0 ; Rcv_integral = 0.0 + do k2=k_end(k-1) + 1,k_end(k) + h_col(k) = h_col(k) + dp_in(k2) + Rcv_integral = Rcv_integral + dp_in(k2)*Rcv_in(k2) + enddo + if (h_col(k) > GV%H_subroundoff) then + ! Take the volume-weighted average properties. + Rcv(k) = Rcv_integral / h_col(k) + else ! Take the properties of the topmost source layer that contributes. + Rcv(k) = Rcv_in(k_end(k-1) + 1) + endif + enddo + endif + + ! Set the target densities for the new layers. + do k=1,CS%nk + ! Rcv_tgt(k) = theta(i,j,k) ! If a 3-d target density were set up in theta, use that here. + Rcv_tgt(k) = CS%target_density(k) ! MOM6 does not yet support 3-d target densities. + 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 + 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 + + ! Convert the regridding parameters into specific constraints for this column. + call hybgen_column_init(nk, CS%nsigma, CS%dp0k, CS%ds0k, CS%dp00i, & + CS%topiso_const, CS%qhybrlx, CS%dpns, CS%dsns, h_tot, dilate, & + h_col, fixlay, qhrlx, dp0ij, dp0cum) + + ! Determine whether to require the use of PCM remapping from each source layer. + do k=1,GV%ke + if (CS%hybiso > 0.0) then + ! --- thin or isopycnal source layers are remapped with PCM. + PCM_lay(k) = (k > fixlay) .and. (abs(Rcv(k) - Rcv_tgt(k)) < CS%hybiso) + else ! hybiso==0.0, so purely isopycnal layers use PCM + PCM_lay(k) = .false. + endif ! hybiso + 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, & + dp0cum, Rcv, h_col, dz_int) + + ! Store the output from hybgenaij_regrid in 3-d arrays. + if (present(PCM_cell)) then ; do k=1,GV%ke + PCM_cell(i,j,k) = PCM_lay(k) + enddo ; endif + + do K=1,nk+1 + ! Note that dzInterface uses the opposite sign convention from the change in p. + dzInterface(i,j,K) = -dz_int(K) + enddo + + else + if (present(PCM_cell)) then ; do k=1,GV%ke + PCM_cell(i,j,k) = .false. + enddo ; endif + do k=1,CS%nk+1 ; dzInterface(i,j,k) = 0.0 ; enddo + endif ; enddo ; enddo !i & j. + +end subroutine hybgen_regrid + +!> Initialize some of the variables that are used for regridding or unmixing, including the +!! stretched contraits on where the new interfaces can be. +subroutine hybgen_column_init(nk, nsigma, dp0k, ds0k, dp00i, topiso_i_j, & + qhybrlx, dpns, dsns, h_tot, dilate, h_col, & + fixlay, qhrlx, dp0ij, dp0cum) + integer, intent(in) :: nk !< The number of layers in the new grid + integer, intent(in) :: nsigma !< The number of sigma levels + real, intent(in) :: dp0k(nk) !< Layer deep z-level spacing minimum thicknesses [H ~> m or kg m-2] + real, intent(in) :: ds0k(nsigma) !< Layer shallow z-level spacing minimum thicknesses [H ~> m or kg m-2] + real, intent(in) :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real, intent(in) :: topiso_i_j !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + real, intent(in) :: qhybrlx !< Fractional relaxation amount per timestep, 0 < qyhbrlx <= 1 [nondim] + real, intent(in) :: h_tot !< The sum of the initial layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: dilate !< A factor by which to dilate the target positions + !! from z to z* [nondim] + real, intent(in) :: h_col(nk) !< Initial layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: dpns !< Vertical sum of dp0k [H ~> m or kg m-2] + real, intent(in) :: dsns !< Vertical sum of ds0k [H ~> m or kg m-2] + integer, intent(out) :: fixlay !< Deepest fixed coordinate layer + real, intent(out) :: qhrlx(nk+1) !< Fractional relaxation within a timestep (between 0 and 1) [nondim] + real, intent(out) :: dp0ij(nk) !< minimum layer thickness [H ~> m or kg m-2] + real, intent(out) :: dp0cum(nk+1) !< minimum interface depth [H ~> m or kg m-2] + + ! --- -------------------------------------------------------------- + ! --- hybrid grid generator, single column - initialization. + ! --- -------------------------------------------------------------- + + ! Local variables + character(len=256) :: mesg ! A string for output messages + real :: hybrlx ! The relaxation rate in the hybrid region [timestep-1]? + real :: qdep ! Total water column thickness as a fraction of dp0k (vs ds0k) [nondim] + real :: q ! A portion of the thickness that contributes to the new cell [H ~> m or kg m-2] + real :: p_int(nk+1) ! Interface depths [H ~> m or kg m-2] + integer :: k, fixall + + ! --- dpns = sum(dp0k(k),k=1,nsigma) + ! --- dsns = sum(ds0k(k),k=1,nsigma) + ! --- terrain following starts (on the deep side) at depth dpns and ends (on the + ! --- shallow side) at depth dsns and the depth of the k-th layer interface varies + ! --- linearly with total depth between these two reference depths. + if ((h_tot >= dilate * dpns) .or. (dpns <= dsns)) then + qdep = 1.0 ! Not terrain following - this column is too thick or terrain following is disabled. + elseif (h_tot <= dilate * dsns) then + qdep = 0.0 ! Not terrain following - this column is too thin + else + qdep = (h_tot - dilate * dsns) / (dilate * (dpns - dsns)) + endif + + if (qdep < 1.0) then + ! Terrain following or shallow fixed coordinates, qhrlx=1 and ignore dp00 + p_int( 1) = 0.0 + dp0cum(1) = 0.0 + qhrlx( 1) = 1.0 + dp0ij( 1) = dilate * (qdep*dp0k(1) + (1.0-qdep)*ds0k(1)) + + dp0cum(2) = dp0cum(1) + dp0ij(1) + qhrlx( 2) = 1.0 + p_int( 2) = p_int(1) + h_col(1) + do k=2,nk + qhrlx( k+1) = 1.0 + dp0ij( k) = dilate * (qdep*dp0k(k) + (1.0-qdep)*ds0k(k)) + dp0cum(k+1) = dp0cum(k) + dp0ij(k) + p_int( k+1) = p_int(k) + h_col(k) + enddo !k + else + ! Not terrain following + p_int( 1) = 0.0 + dp0cum(1) = 0.0 + qhrlx( 1) = 1.0 !no relaxation in top layer + dp0ij( 1) = dilate * dp0k(1) + + dp0cum(2) = dp0cum(1) + dp0ij(1) + qhrlx( 2) = 1.0 !no relaxation in top layer + p_int( 2) = p_int(1) + h_col(1) + do k=2,nk + if ((dp0k(k) <= dp00i) .or. (dilate * dp0k(k) >= p_int(k) - dp0cum(k))) then + ! This layer is in fixed surface coordinates. + dp0ij(k) = dp0k(k) + qhrlx(k+1) = 1.0 + else + q = dp0k(k) * (dilate * dp0k(k) / ( p_int(k) - dp0cum(k)) ) ! A fraction between 0 and 1 of dp0 to use here. + if (dp00i >= q) then + ! This layer is much deeper than the fixed surface coordinates. + dp0ij(k) = dp00i + qhrlx(k+1) = qhybrlx + else + ! This layer spans the margins of the fixed surface coordinates. + ! In this case dp00i < q < dp0k. + dp0ij(k) = dilate * q + qhrlx(k+1) = qhybrlx * (dp0k(k) - dp00i) / & + ((dp0k(k) - q) + (q - dp00i)*qhybrlx) ! 1 at dp0k, qhybrlx at dp00i + endif + + ! The old equivalent code is: + ! hybrlx = 1.0 / qhybrlx + ! q = max( dp00i, dp0k(k) * (dp0k(k) / max(dp0k( k), p_int(k) - dp0cum(k)) ) ) + ! qts = 1.0 - (q-dp00i) / (dp0k(k) - dp00i) !0 at q = dp0k, 1 at q=dp00i + ! qhrlx( k+1) = 1.0 / (1.0 + qts*(hybrlx-1.0)) !1 at dp0k, qhybrlx at dp00i + endif + dp0cum(k+1) = dp0cum(k) + dp0ij(k) + p_int(k+1) = p_int(k) + h_col(k) + enddo !k + endif !qdep<1:else + + ! Identify the current fixed coordinate layers + fixlay = 1 !layer 1 always fixed + do k=2,nk + if (dp0cum(k) >= dilate * topiso_i_j) then + exit !layers k to nk might be isopycnal + endif + ! Top of layer is above topiso, i.e. always fixed coordinate layer + qhrlx(k+1) = 1.0 !no relaxation in fixed layers + fixlay = fixlay+1 + enddo !k + + fixall = fixlay + do k=fixall+1,nk + if (p_int(k+1) > dp0cum(k+1) + 0.1*dp0ij(k)) then + if ( (fixlay > fixall) .and. (p_int(k) > dp0cum(k)) ) then + ! --- The previous layer should remain fixed. + fixlay = fixlay-1 + endif + exit !layers k to nk might be isopycnal + endif + ! Sometimes fixed coordinate layer + qhrlx(k) = 1.0 !no relaxation in fixed layers + fixlay = fixlay+1 + enddo !k + +end subroutine hybgen_column_init + +!> The cushion function from Bleck & Benjamin, 1992, which returns a smoothly varying +!! but limited value that goes between dp0 and delp +real function cushn(delp, dp0) + real, intent(in) :: delp ! A thickness change [H ~> m or kg m-2] + real, intent(in) :: dp0 ! A non-negative reference thickness [H ~> m or kg m-2] + + real :: qq ! A limited ratio of delp/dp0 [nondim] + + ! These are the nondimensional parameters that define the cushion function. + 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] + ! These are derivative nondimensional parameters. + ! real, parameter :: cusha = qqmn**2 * (qqmx-1.0) / (qqmx-qqmn)**2 + ! real, parameter :: I_qqmn = 1.0 / qqmn + real, parameter :: qq_scale = (qqmx-1.0) / (qqmx-qqmn)**2 + real, parameter :: I_qqmx = 1.0 / qqmx + + ! --- if delp >= qqmx*dp0 >> dp0, cushn returns delp. + ! --- if delp <= qqmn*dp0 << -dp0, cushn returns dp0. + + ! This is the original version from Hycom. + ! qq = max(qqmn, min(qqmx, delp/dp0)) + ! cushn = dp0 * (1.0 + cusha * (1.0-I_qqmn*qq)**2) * max(1.0, delp/(dp0*qqmx)) + + ! This is mathematically equivalent, has one fewer divide, and works as intended even if dp0 = 0. + if (delp >= qqmx*dp0) then + cushn = delp + elseif (delp < qqmn*dp0) then + cushn = max(dp0, delp * I_qqmx) + else + cushn = max(dp0, delp * I_qqmx) * (1.0 + qq_scale * ((delp / dp0) - qqmn)**2) + endif + +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, & + 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] + real, intent(in) :: dp0ij( nk) !< minimum layer thickness [H ~> m or kg m-2] + real, intent(in) :: dp0cum(nk+1) !< minimum interface depth [H ~> m or kg m-2] + real, intent(in) :: Rcv(nk) !< Coordinate potential density [R ~> kg m-3] + real, intent(in) :: h_in(nk) !< Layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: dp_int(nk+1) !< The change in interface positions [H ~> m or kg m-2] + + ! --- ------------------------------------------------------ + ! --- hybrid grid generator, single column - regrid. + ! --- ------------------------------------------------------ + + ! Local variables + real :: p_new ! A new interface position [H ~> m or kg m-2] + real :: pres_in(nk+1) ! layer interface positions [H ~> m or kg m-2] + real :: p_int(nk+1) ! layer interface positions [H ~> m or kg m-2] + real :: h_col(nk) ! Updated layer thicknesses [H ~> m or kg m-2] + real :: q_frac ! A fraction of a layer to entrain [nondim] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2] + real :: h_hat3 ! Thickness movement upward across the interface between layers k-2 and k-3 [H ~> m or kg m-2] + real :: h_hat2 ! Thickness movement upward across the interface between layers k-1 and k-2 [H ~> m or kg m-2] + real :: h_hat ! Thickness movement upward across the interface between layers k and k-1 [H ~> m or kg m-2] + 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 :: h1_tgt ! A target thickness for the top layer [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 + + trap_errors = .true. + + do K=1,nk+1 ; dp_int(K) = 0.0 ; enddo + + p_int(1) = 0.0 + do k=1,nk + h_col(k) = max(h_in(k), 0.0) + p_int(K+1) = p_int(K) + h_col(k) + enddo + h_min = min( CS%min_thickness, p_int(nk+1)/real(CS%nk) ) + + if (trap_errors) then + do K=1,nk+1 ; pres_in(K) = p_int(K) ; enddo + endif + + ! Try to restore isopycnic conditions by moving layer interfaces + ! qhrlx(k) are relaxation amounts per timestep. + + ! Maintain prescribed thickness in layer k <= fixlay + ! There may be massless layers at the bottom, so work upwards. + do k=min(nk-1,fixlay),1,-1 + p_new = min(dp0cum(k+1), p_int(nk+1) - (nk-k)*h_min) ! This could be positive or negative. + dh_cor = p_new - p_int(K+1) + if (k= h_min) exit ! usually get here quickly + dh_cor = h_min - h_col(k) ! This is positive. + h_col(k) = h_min ! = h_col(k) + dh_cor + h_col(k+1) = h_col(k+1) - dh_cor + dp_int(k+1) = dp_int(k+1) + dh_cor + p_int(k+1) = p_int(fixlay+1) + enddo + if (h_col(nk) < h_min) then ! This should be uncommon, and should only arise at the level of roundoff. + do k=nk,2,-1 + if (h_col(k) >= h_min) exit + dh_cor = h_col(k) - h_min ! dh_cor is negative. + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_min ! = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + enddo + endif + + ! Remap the non-fixed layers. + + ! In the Hycom version, this loop was fused 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 + ! 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 + ! 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. & + (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 + ! 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. + h_hat0 = 0.0 ! This line was not in the Hycom version of hybgen.F90. + h_hat = dp0ij(k-1) - h_col(k-1) + else + ! Entrain enough from the layer above to bring layer k to its target density. + q_frac = (Rcv_tgt(k) - Rcv(k)) / (Rcv_tgt(k) - Rcv(k-1)) ! -1 <= q_frac < 0 + h_hat0 = q_frac*h_col(k) ! -h_col(k-1) <= h_hat0 < 0 + if (k == fixlay+2) then + ! Treat layer k-1 as fixed. + h_hat = max(h_hat0, dp0ij(k-1) - h_col(k-1)) + else + ! Maintain the minimum thickess of layer k-1. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + endif !fixlay+2:else + endif + ! h_hat is usually negative, so this check may be unnecessary if the values of + ! dp0ij are limited to not be below the seafloor? + h_hat = min(h_hat, p_int(nk+1) - p_int(k)) + + ! If isopycnic conditions cannot be achieved because of a blocking + ! 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 + + ! 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. & + (h_col(k-2) > qqmx*dp0ij(k-2)) ) then + ! Determine how much water layer k-2 could supply without becoming too thin. + if (k == fixlay+3) then + ! Treat layer k-2 as fixed. + h_hat2 = max(h_hat0 - h_hat, dp0ij(k-2) - h_col(k-2)) + else + ! Maintain minimum thickess of layer k-2. + 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 + 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 + dp_int(k-1) = dp_int(k-1) + dh_cor + p_int(k-1) = p_int(k-1) + dh_cor + ! Recalculate how much layer k-1 could donate to layer k. + 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 + + ! Determine how much water layer k-3 could supply without becoming too thin. + if (k == fixlay+4) then + ! Treat layer k-3 as fixed. + h_hat3 = max(h_hat0 - h_hat, dp0ij(k-3) - h_col(k-3)) + else + ! 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 + ! 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 + h_col(k-2) = h_col(k-2) - dh_cor + dp_int(k-2) = dp_int(k-2) + dh_cor + p_int(k-2) = p_int(k-2) + dh_cor + + ! 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 + 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 + dp_int(k-1) = dp_int(k-1) + dh_cor + p_int(k-1) = p_int(k-1) + dh_cor + ! Recalculate how much layer k-1 could donate to layer k. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + endif !h_hat2 + endif !h_hat3 + endif !h_hat2:blocking + endif ! Layer k-2 could move. + endif ! blocking, i.e., h_hat >= 0, and far enough from the fixed layers to permit a change. + + if (h_hat < 0.0) then + ! entrain layer k-1 water into layer k, move interface up. + dh_cor = qhrlx(k) * h_hat + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + endif !entrain + + endif !too-dense adjustment + endif + + ! In the original Hycom version, there is not a break between these two loops. + enddo + + do k=fixlay+1,nk + if (Rcv(k) < Rcv_tgt(k) - epsil) 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 dp0ij(k) + dp0ij(k+1)) then + h_hat = h_col(k+1) - cushn(h_col(k+1) - h_hat, dp0ij(k+1)) + endif + ! Try to bring layer layer k up to its minimum thickness. + h_hat = max(h_hat, dp0ij(k) - h_col(k)) + ! Do not drive layer k+1 below its minimum thickness or take more than half of it. + h_hat = min(h_hat, max(0.5*h_col(k+1), h_col(k+1) - dp0ij(k+1)) ) + else + ! Layers that touch the bottom can lose their entire contents. + h_hat = min(h_col(k+1), h_hat) + endif !p.k+2 0.0) then + ! Entrain layer k+1 water into layer k. + dh_cor = qhrlx(k+1) * h_hat + h_col(k) = h_col(k) + dh_cor + h_col(k+1) = h_col(k+1) - dh_cor + dp_int(k+1) = dp_int(k+1) + dh_cor + p_int(k+1) = p_int(k+1) + dh_cor + endif !entrain + + endif !too-light adjustment + endif !above bottom + endif !too light + + ! If layer above is still too thin, move interface down. + dh_cor = min(qhrlx(k-1) * min(dp0ij(k-1) - h_col(k-1), p_int(nk+1) - p_int(k)), h_col(k)) + if (dh_cor > 0.0) then + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + endif + + enddo !k Hybrid vertical coordinate relocation moving interface downward + + if (trap_errors) then + ! Verify that everything is consistent. + do k=1,nk + if (abs((h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1))) > 1.0e-13*max(p_int(nk+1), 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 + 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 + call MOM_error(FATAL, "Mismatched interface height changes in hybgen_regrid.") + endif + enddo + endif + +end subroutine hybgen_column_regrid + +end module MOM_hybgen_regrid + +! This code was translated in 2022 from the HYCOM hybgen code, which was primarily developed +! between 2000 and 2015, with some minor subsequent changes and bug fixes. diff --git a/src/ALE/MOM_hybgen_unmix.F90 b/src/ALE/MOM_hybgen_unmix.F90 new file mode 100644 index 0000000000..6e204f856b --- /dev/null +++ b/src/ALE/MOM_hybgen_unmix.F90 @@ -0,0 +1,502 @@ +!> This module contains the hybgen unmixing routines from HYCOM, with +!! modifications to follow the MOM6 coding conventions and several bugs fixed +module MOM_hybgen_unmix + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING +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_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 +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!> Control structure containing required parameters for the hybgen coordinate generator +type, public :: hybgen_unmix_CS ; private + + integer :: nsigma !< Number of sigma levels used by HYBGEN + real :: hybiso !< Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + + real :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real :: qhybrlx !< Hybgen relaxation amount per thermodynamic time steps [nondim] + + real, allocatable, dimension(:) :: & + dp0k, & !< minimum deep z-layer separation [H ~> m or kg m-2] + ds0k !< minimum shallow z-layer separation [H ~> m or kg m-2] + + real :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real :: min_dilate !< The minimum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when wetting occurs. + real :: max_dilate !< The maximum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when drying occurs. + + real :: topiso_const !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + ! real, dimension(:,:), allocatable :: topiso + + real :: ref_pressure !< Reference pressure for density calculations [R L2 T-2 ~> Pa] + real, allocatable, dimension(:) :: target_density !< Nominal density of interfaces [R ~> kg m-3] + +end type hybgen_unmix_CS + +public hybgen_unmix, init_hybgen_unmix, end_hybgen_unmix +public set_hybgen_unmix_params + +contains + +!> Initialise a hybgen_unmix_CS control structure and store its parameters +subroutine init_hybgen_unmix(CS, GV, US, param_file, hybgen_regridCS) + type(hybgen_unmix_CS), pointer :: CS !< Unassociated pointer to hold the control 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 + type(hybgen_regrid_CS), pointer :: hybgen_regridCS !< Control structure for hybgen + !! regridding for sharing parameters. + + character(len=40) :: mdl = "MOM_hybgen" ! This module's name. + integer :: k + + if (associated(CS)) call MOM_error(FATAL, "init_hybgen_unmix: CS already associated!") + allocate(CS) + allocate(CS%target_density(GV%ke)) + + allocate(CS%dp0k(GV%ke), source=0.0) ! minimum deep z-layer separation + allocate(CS%ds0k(GV%ke), source=0.0) ! minimum shallow z-layer separation + + ! Set the parameters for the hybgen unmixing from a hybgen regridding control structure. + call get_hybgen_regrid_params(hybgen_regridCS, ref_pressure=CS%ref_pressure, & + nsigma=CS%nsigma, dp0k=CS%dp0k, ds0k=CS%ds0k, & + dp00i=CS%dp00i, topiso_const=CS%topiso_const, qhybrlx=CS%qhybrlx, & + hybiso=CS%hybiso, min_dilate=CS%min_dilate, max_dilate=CS%max_dilate, & + target_density=CS%target_density) + + ! Determine the depth range over which to use a sigma (terrain-following) coordinate. + ! --- terrain following starts at depth dpns and ends at depth dsns + if (CS%nsigma == 0) then + CS%dpns = CS%dp0k(1) + CS%dsns = 0.0 + else + CS%dpns = 0.0 + CS%dsns = 0.0 + do k=1,CS%nsigma + CS%dpns = CS%dpns + CS%dp0k(k) + CS%dsns = CS%dsns + CS%ds0k(k) + enddo !k + endif !nsigma + +end subroutine init_hybgen_unmix + +!> This subroutine deallocates memory in the control structure for the hybgen unmixing module +subroutine end_hybgen_unmix(CS) + type(hybgen_unmix_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + + deallocate(CS%target_density) + deallocate(CS%dp0k, CS%ds0k) + deallocate(CS) +end subroutine end_hybgen_unmix + +!> This subroutine can be used to set the parameters for the hybgen module +subroutine set_hybgen_unmix_params(CS, min_thickness) + type(hybgen_unmix_CS), pointer :: CS !< Coordinate unmixing control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] + + if (.not. associated(CS)) call MOM_error(FATAL, "set_hybgen_params: CS not associated") + +! if (present(min_thickness)) CS%min_thickness = min_thickness +end subroutine set_hybgen_unmix_params + + +!> Unmix the properties in the lowest layer with mass if it is too light, and make +!! any other changes to the water column to prepare for regridding. +subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(hybgen_unmix_CS), intent(in) :: CS !< hybgen control structure + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + integer, intent(in) :: ntr !< The number of tracers in the registry, or + !! 0 if the registry is not in use. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + +! --- -------------------------------------------- +! --- hybrid grid generator, single j-row (part A). +! --- -------------------------------------------- + + character(len=256) :: mesg ! A string for output messages + integer :: fixlay ! deepest fixed coordinate layer + real :: qhrlx( GV%ke+1) ! relaxation coefficient per timestep [nondim] + real :: dp0ij( GV%ke) ! minimum layer thickness [H ~> m or kg m-2] + real :: dp0cum(GV%ke+1) ! minimum interface depth [H ~> m or kg m-2] + + real :: Rcv_tgt(GV%ke) ! Target potential density [R ~> kg m-3] + real :: temp(GV%ke) ! A column of potential temperature [degC] + real :: saln(GV%ke) ! A column of salinity [ppt] + real :: Rcv(GV%ke) ! A column of coordinate potential density [R ~> kg m-3] + real :: h_col(GV%ke) ! A column of layer thicknesses [H ~> m or kg m-2] + 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 :: 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] + + real :: Th_tot_in, Th_tot_out ! Column integrated temperature [degC H ~> degC m or degC kg m-2] + real :: Sh_tot_in, Sh_tot_out ! Column integrated salinity [ppt H ~> ppt m or ppt kg m-2] + real :: Trh_tot_in(max(ntr,1)) ! Initial column integrated tracer amounts [conc H ~> conc m or conc kg m-2] + real :: Trh_tot_out(max(ntr,1)) ! Final column integrated tracer amounts [conc H ~> conc m or conc kg m-2] + + logical :: debug_conservation ! If true, test for non-conservation. + logical :: terrain_following ! True if this column is terrain following. + integer :: trcflg(max(ntr,1)) ! Hycom tracer type flag for each tracer + integer :: i, j, k, nk, m + + nk = GV%ke + + ! Set all tracers to be passive. Setting this to 2 treats a tracer like temperature. + trcflg(:) = 3 + + h_thin = 1e-6*GV%m_to_H + debug_conservation = .false. ! Set this to true for debugging + + 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 + + h_tot = 0.0 + do k=1,nk + ! Rcv_tgt(k) = theta(i,j,k) ! If a 3-d target density were set up in theta, use that here. + Rcv_tgt(k) = CS%target_density(k) ! MOM6 does not yet support 3-d target densities. + h_col(k) = h(i,j,k) + h_tot = h_tot + h_col(k) + temp(k) = tv%T(i,j,k) + saln(k) = tv%S(i,j,k) + enddo + + ! This sets the potential density from T and S. + call calculate_density(temp, saln, p_col, Rcv, tv%eqn_of_state) + + do m=1,ntr ; do k=1,nk + tracer(k,m) = Reg%Tr(m)%t(i,j,k) + enddo ; enddo + + ! Store original amounts to test for conservation of temperature, salinity, and tracers. + if (debug_conservation) then + Th_tot_in = 0.0 ; Sh_tot_in = 0.0 ; Trh_tot_in(:) = 0.0 + do k=1,nk + Sh_tot_in = Sh_tot_in + h_col(k)*saln(k) + Th_tot_in = Th_tot_in + h_col(k)*temp(k) + enddo + do m=1,ntr ; do k=1,nk + Trh_tot_in(m) = Trh_tot_in(m) + h_col(k)*tracer(k,m) + enddo ; enddo + 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 + else + dilate = h_tot / nominalDepth + endif + + terrain_following = (h_tot < dilate*CS%dpns) .and. (CS%dpns >= CS%dsns) + + ! Convert the regridding parameters into specific constraints for this column. + call hybgen_column_init(nk, CS%nsigma, CS%dp0k, CS%ds0k, CS%dp00i, & + CS%topiso_const, CS%qhybrlx, CS%dpns, CS%dsns, h_tot, dilate, & + h_col, fixlay, qhrlx, dp0ij, dp0cum) + + ! Do any unmixing of the column that is needed to move the layer properties toward their targets. + call hybgen_column_unmix(CS, nk, Rcv_tgt, temp, saln, Rcv, tv%eqn_of_state, & + ntr, tracer, trcflg, fixlay, qhrlx, h_col, & + terrain_following, h_thin) + + ! Store the output from hybgen_unmix in the 3-d arrays. + do k=1,nk + h(i,j,k) = h_col(k) + enddo + ! Note that temperature and salinity are among the tracers unmixed here. + do m=1,ntr ; do k=1,nk + Reg%Tr(m)%t(i,j,k) = tracer(k,m) + enddo ; enddo + ! However, temperature and salinity may have been treated differently from other tracers. + do k=1,nk + tv%T(i,j,k) = temp(k) + tv%S(i,j,k) = saln(k) + enddo + + ! Test for conservation of temperature, salinity, and tracers. + if (debug_conservation) then + Th_tot_out = 0.0 ; Sh_tot_out = 0.0 ; Trh_tot_out(:) = 0.0 + do k=1,nk + Sh_tot_out = Sh_tot_out + h_col(k)*saln(k) + Th_tot_out = Th_tot_out + h_col(k)*temp(k) + enddo + do m=1,ntr ; do k=1,nk + Trh_tot_out(m) = Trh_tot_out(m) + h_col(k)*tracer(k,m) + enddo ; enddo + if (abs(Sh_tot_in - Sh_tot_out) > 1.e-15*(abs(Sh_tot_in) + abs(Sh_tot_out))) then + write(mesg, '("i,j=",2i8,"Sh_tot = ",2es17.8," err = ",es13.4)') & + i, j, Sh_tot_in, Sh_tot_out, (Sh_tot_in - Sh_tot_out) + call MOM_error(FATAL, "Mismatched column salinity in hybgen_unmix: "//trim(mesg)) + endif + if (abs(Th_tot_in - Th_tot_out) > 1.e-10*(abs(Th_tot_in) + abs(Th_tot_out))) then + write(mesg, '("i,j=",2i8,"Th_tot = ",2es17.8," err = ",es13.4)') & + i, j, Th_tot_in, Th_tot_out, (Th_tot_in - Th_tot_out) + call MOM_error(FATAL, "Mismatched column temperature in hybgen_unmix: "//trim(mesg)) + endif + do m=1,ntr + if (abs(Trh_tot_in(m) - Trh_tot_out(m)) > 1.e-10*(abs(Trh_tot_in(m)) + abs(Trh_tot_out(m)))) then + write(mesg, '("i,j=",2i8,"Trh_tot(",i2,") = ",2es17.8," err = ",es13.4)') & + i, j, m, Trh_tot_in(m), Trh_tot_out(m), (Trh_tot_in(m) - Trh_tot_out(m)) + call MOM_error(FATAL, "Mismatched column tracer in hybgen_unmix: "//trim(mesg)) + endif + enddo + endif + endif ; enddo ; enddo !i & j. + +end subroutine hybgen_unmix + + +!> Unmix the properties in the lowest layer if it is too light. +subroutine hybgen_column_unmix(CS, nk, Rcv_tgt, temp, saln, Rcv, eqn_of_state, & + ntr, tracer, trcflg, fixlay, qhrlx, h_col, & + terrain_following, h_thin) + type(hybgen_unmix_CS), intent(in) :: CS !< hybgen unmixing control structure + integer, intent(in) :: nk !< The number of layers + integer, intent(in) :: fixlay !< deepest fixed coordinate layer + real, intent(in) :: qhrlx(nk+1) !< Relaxation fraction per timestep [nondim], < 1. + real, intent(in) :: Rcv_tgt(nk) !< Target potential density [R ~> kg m-3] + real, intent(inout) :: temp(nk) !< A column of potential temperature [degC] + real, intent(inout) :: saln(nk) !< A column of salinity [ppt] + real, intent(inout) :: Rcv(nk) !< Coordinate potential density [R ~> kg m-3] + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + integer, intent(in) :: ntr !< The number of registered passive tracers + real, intent(inout) :: tracer(nk, max(ntr,1)) !< Columns of the passive tracers [Conc] + integer, intent(in) :: trcflg(max(ntr,1)) !< Hycom tracer type flag for each tracer + real, intent(inout) :: h_col(nk+1) !< Layer thicknesses [H ~> m or kg m-2] + logical, intent(in) :: terrain_following !< True if this column is terrain following + real, intent(in) :: h_thin !< A negligibly small thickness to identify + !! essentially vanished layers [H ~> m or kg m-2] + +! +! --- ------------------------------------------------------------------ +! --- hybrid grid generator, single column - ummix lowest massive layer. +! --- ------------------------------------------------------------------ +! + ! Local variables + real :: h_hat ! A portion of a layer to move across an interface [H ~> m or kg m-2] + real :: delt, deltm ! Temperature differences between successive layers [degC] + real :: dels, delsm ! Salinity differences between successive layers [ppt] + real :: abs_dRdT ! The absolute value of the derivative of the coordinate density + ! with temperature [R degC-1 ~> kg m-3 degC-1] + real :: abs_dRdS ! The absolute value of the derivative of the coordinate density + ! with salinity [R ppt-1 ~> kg m-3 ppt-1] + real :: q, qts ! Nondimensional fractions in the range of 0 to 1 [nondim] + real :: frac_dts ! The fraction of the temperature or salinity difference between successive + ! layers by which the source layer's property changes by the loss of water + ! that matches the destination layers properties via unmixing [nondim]. + real :: qtr ! The fraction of the water that will come from the layer below, + ! used for updating the concentration of passive tracers [nondim] + real :: swap_T ! A swap variable for temperature [degC] + real :: swap_S ! A swap variable for salinity [ppt] + real :: swap_R ! A swap variable for the coordinate potential density [R ~> kg m-3] + real :: swap_tr ! A temporary swap variable for the tracers [conc] + logical, parameter :: lunmix=.true. ! unmix a too light deepest layer + integer :: k, ka, kp, kt, m + + ! --- identify the deepest layer kp with significant thickness (> h_thin) + kp = 2 !minimum allowed value + do k=nk,3,-1 + if (h_col(k) >= h_thin) then + kp = k + exit + endif + enddo !k + + k = kp !at least 2 + ka = max(k-2,1) !k might be 2 +! + if ( ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv_tgt(k) > Rcv(k)) .and. & ! layer is lighter than its target + ((Rcv(k-1) > Rcv(k)) .and. (Rcv(ka) > Rcv(k))) ) then +! +! --- water in the deepest inflated layer with significant thickness +! --- (kp) is too light, and it is lighter than the two layers above. +! --- +! --- this should only occur when relaxing or nudging layer thickness +! --- and is a bug (bad interaction with tsadvc) even in those cases +! --- +! --- entrain the entire layer into the one above +!--- note the double negative in T=T-q*(T-T'), equiv. to T=T+q*(T'-T) + q = h_col(k) / (h_col(k) + h_col(k-1)) + temp(k-1) = temp(k-1) - q*(temp(k-1) - temp(k)) + saln(k-1) = saln(k-1) - q*(saln(k-1) - saln(k)) + call calculate_density(temp(k-1), saln(k-1), CS%ref_pressure, Rcv(k-1), eqn_of_state) + + do m=1,ntr + tracer(k-1,m) = tracer(k-1,m) - q*(tracer(k-1,m) - tracer(k,m) ) + enddo !m +! --- entrained the entire layer into the one above, so now kp=kp-1 + h_col(k-1) = h_col(k-1) + h_col(k) + h_col(k) = 0.0 + kp = k-1 + elseif ( ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv_tgt(k) > Rcv(k)) .and. & ! layer is lighter than its target + (Rcv(k-1) > Rcv(k)) ) then +! --- water in the deepest inflated layer with significant thickness +! --- (kp) is too light, and it is lighter than the layer above, but not the layer two above. +! --- +! --- swap the entire layer with the one above. + if (h_col(k) <= h_col(k-1)) then + ! The bottom layer is thinner; swap the entire bottom layer with a portion of the layer above. + q = h_col(k) / h_col(k-1) !<=1.0 + + swap_T = temp(k-1) + temp(k-1) = temp(k-1) + q*(temp(k) - temp(k-1)) + temp(k) = swap_T + + swap_S = saln(k-1) + saln(k-1) = saln(k-1) + q*(saln(k) - saln(k-1)) + saln(k) = swap_S + + Rcv(k) = Rcv(k-1) + call calculate_density(temp(k-1), saln(k-1), CS%ref_pressure, Rcv(k-1), eqn_of_state) + + do m=1,ntr + swap_tr = tracer(k-1,m) + tracer(k-1,m) = tracer(k-1,m) - q * (tracer(k-1,m) - tracer(k,m)) + tracer(k,m) = swap_tr + enddo !m + else + ! The bottom layer is thicker; swap the entire layer above with a portion of the bottom layer. + q = h_col(k-1) / h_col(k) !<1.0 + + swap_T = temp(k) + temp(k) = temp(k) + q*(temp(k-1) - temp(k)) + temp(k-1) = swap_T + + swap_S = saln(k) + saln(k) = saln(k) + q*(saln(k-1) - saln(k)) + saln(k-1) = swap_S + + Rcv(k-1) = Rcv(k) + call calculate_density(temp(k), saln(k), CS%ref_pressure, Rcv(k), eqn_of_state) + + do m=1,ntr + swap_tr = tracer(k,m) + tracer(k,m) = tracer(k,m) + q * (tracer(k-1,m) - tracer(k,m)) + tracer(k-1,m) = swap_tr + enddo !m + endif !bottom too light + endif + + k = kp !at least 2 + ka = max(k-2,1) !k might be 2 + + if ( lunmix .and. & ! usually .true. + ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv(k) < Rcv_tgt(k)) .and. & ! layer is lighter than its target + (Rcv(k) > Rcv_tgt(k-1)) .and. & ! layer is denser than the target above + (abs(Rcv_tgt(k-1) - Rcv(k-1)) < CS%hybiso) .and. & ! layer above is near its target + (Rcv(k) - Rcv(k-1) > 0.001*(Rcv_tgt(k) - Rcv_tgt(k-1))) ) then +! +! --- water in the deepest inflated layer with significant thickness (kp) is too +! --- light but denser than the layer above, with the layer above near-isopycnal +! --- +! --- split layer into 2 sublayers, one near the desired density +! --- and one exactly matching the T&S properties of layer k-1. +! --- To prevent "runaway" T or S, the result satisfies either +! --- abs(T.k - T.k-1) <= abs(T.k-N - T.k-1) or +! --- abs(S.k - S.k-1) <= abs(S.k-N - S.k-1) where +! --- Rcv.k-1 - Rcv.k-N is at least Rcv_tgt(k-1) - Rcv_tgt(k-2) +! --- It is also limited to a 50% change in layer thickness. + + ka = 1 + do kt=k-2,2,-1 + if ( Rcv(k-1) - Rcv(kt) >= Rcv_tgt(k-1) - Rcv_tgt(k-2) ) then + ka = kt !usually k-2 + exit + endif + enddo + + delsm = abs(saln(ka) - saln(k-1)) + dels = abs(saln(k-1) - saln(k)) + deltm = abs(temp(ka) - temp(k-1)) + delt = abs(temp(k-1) - temp(k)) + + call calculate_density_derivs(temp(k-1), saln(k-1), CS%ref_pressure, abs_dRdT, abs_dRdS, eqn_of_state) + ! Bound deltm and delsm based on the equation of state and density differences between layers. + abs_dRdT = abs(abs_dRdT) ; abs_dRdS = abs(abs_dRdS) + if (abs_dRdT * deltm > Rcv_tgt(k)-Rcv_tgt(k-1)) deltm = (Rcv_tgt(k)-Rcv_tgt(k-1)) / abs_dRdT + if (abs_dRdS * delsm > Rcv_tgt(k)-Rcv_tgt(k-1)) delsm = (Rcv_tgt(k)-Rcv_tgt(k-1)) / abs_dRdS + + qts = 0.0 + if (qts*dels < min(delsm-dels, dels)) qts = min(delsm-dels, dels) / dels + if (qts*delt < min(deltm-delt, delt)) qts = min(deltm-delt, delt) / delt + + ! Note that Rcv_tgt(k) > Rcv(k) > Rcv(k-1), and 0 <= qts <= 1. + ! qhrlx is relaxation coefficient (inverse baroclinic time steps), 0 <= qhrlx <= 1. + ! This takes the minimum of the two estimates. + if ((1.0+qts) * (Rcv_tgt(k)-Rcv(k)) < qts * (Rcv_tgt(k)-Rcv(k-1))) then + q = qhrlx(k) * ((Rcv_tgt(k)-Rcv(k)) / (Rcv_tgt(k)-Rcv(k-1))) + else + q = qhrlx(k) * (qts / (1.0+qts)) ! upper sublayer <= 50% of total + endif + frac_dts = q / (1.0-q) ! 0 <= q <= 0.5, so 0 <= frac_dts <= 1 + + h_hat = q * h_col(k) + h_col(k-1) = h_col(k-1) + h_hat + h_col(k) = h_col(k) - h_hat + + temp(k) = temp(k) + frac_dts * (temp(k) - temp(k-1)) + saln(k) = saln(k) + frac_dts * (saln(k) - saln(k-1)) + call calculate_density(temp(k), saln(k), CS%ref_pressure, Rcv(k), eqn_of_state) + + if ((ntr > 0) .and. (h_hat /= 0.0)) then + ! qtr is the fraction of the new upper layer from the old lower layer. + ! The nonconservative original from Hycom: qtr = h_hat / max(h_hat, h_col(k)) !between 0 and 1 + qtr = h_hat / h_col(k-1) ! Between 0 and 1, noting the h_col(k-1) = h_col(k-1) + h_hat above. + do m=1,ntr + if (trcflg(m) == 2) then !temperature tracer + tracer(k,m) = tracer(k,m) + frac_dts * (tracer(k,m) - tracer(k-1,m)) + else !standard tracer - not split into two sub-layers + tracer(k-1,m) = tracer(k-1,m) + qtr * (tracer(k,m) - tracer(k-1,m)) + endif !trcflg + enddo !m + endif !tracers + endif !too light + +! ! Fill properties of massless or near-massless (thickness < h_thin) layers +! ! This was in the Hycom verion, but it appears to be unnecessary in MOM6. +! do k=kp+1,nk +! ! --- fill thin and massless layers on sea floor with fluid from above +! Rcv(k) = Rcv(k-1) +! do m=1,ntr +! tracer(k,m) = tracer(k-1,m) +! enddo !m +! saln(k) = saln(k-1) +! temp(k) = temp(k-1) +! enddo !k + +end subroutine hybgen_column_unmix + +end module MOM_hybgen_unmix diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 4c99ce457d..e7680df0c2 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -21,7 +21,7 @@ module MOM_regridding use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA use regrid_consts, only : REGRIDDING_ARBITRARY, REGRIDDING_SIGMA_SHELF_ZSTAR -use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE +use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike @@ -31,6 +31,8 @@ module MOM_regridding use coord_hycom, only : init_coord_hycom, hycom_CS, set_hycom_params, build_hycom1_column, end_coord_hycom use coord_slight, only : init_coord_slight, slight_CS, set_slight_params, build_slight_column, end_coord_slight use coord_adapt, only : init_coord_adapt, adapt_CS, set_adapt_params, build_adapt_column, end_coord_adapt +use MOM_hybgen_regrid, only : hybgen_regrid, hybgen_regrid_CS, init_hybgen_regrid, end_hybgen_regrid +use MOM_hybgen_regrid, only : write_Hybgen_coord_file implicit none ; private @@ -119,17 +121,21 @@ module MOM_regridding !! If false, use more robust forms of the same remapping expressions. logical :: remap_answers_2018 = .true. + logical :: use_hybgen_unmix = .false. !< If true, use the hybgen unmixing code before remapping + type(zlike_CS), pointer :: zlike_CS => null() !< Control structure for z-like coordinate generator type(sigma_CS), pointer :: sigma_CS => null() !< Control structure for sigma coordinate generator type(rho_CS), pointer :: rho_CS => null() !< Control structure for rho coordinate generator type(hycom_CS), pointer :: hycom_CS => null() !< Control structure for hybrid coordinate generator type(slight_CS), pointer :: slight_CS => null() !< Control structure for Slight-coordinate generator type(adapt_CS), pointer :: adapt_CS => null() !< Control structure for adaptive coordinate generator + type(hybgen_regrid_CS), pointer :: hybgen_CS => NULL() !< Control structure for hybgen regridding end type ! The following routines are visible to the outside world public initialize_regridding, end_regridding, regridding_main +public regridding_preadjust_reqs, convective_adjustment public inflate_vanished_layers_old, check_remapping_grid, check_grid_column public set_regrid_params, get_regrid_size, write_regrid_file public uniformResolution, setCoordinateResolution @@ -148,6 +154,7 @@ module MOM_regridding " SIGMA - terrain following coordinates\n"//& " RHO - continuous isopycnal\n"//& " HYCOM1 - HyCOM-like hybrid coordinate\n"//& + " HYBGEN - Hybrid coordinate from the Hycom hybgen code\n"//& " SLIGHT - stretched coordinates above continuous isopycnal\n"//& " ADAPTIVE - optimize for smooth neutral density surfaces" @@ -458,6 +465,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! This is a work around to apparently needed to work with the from_Z initialization... ??? if (coordinateMode(coord_mode) == REGRIDDING_ZSTAR .or. & coordinateMode(coord_mode) == REGRIDDING_HYCOM1 .or. & + coordinateMode(coord_mode) == REGRIDDING_HYBGEN .or. & coordinateMode(coord_mode) == REGRIDDING_SLIGHT .or. & coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then ! Adjust target grid to be consistent with maximum_depth @@ -511,7 +519,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif ! initialise coordinate-specific control structure - call initCoord(CS, GV, US, coord_mode) + call initCoord(CS, GV, US, coord_mode, param_file) if (main_parameters .and. coord_is_state_dependent) then call get_param(param_file, mdl, "P_REF", P_Ref, & @@ -536,6 +544,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_params(CS, min_thickness=0.) endif + CS%use_hybgen_unmix = .false. + if (coordinateMode(coord_mode) == REGRIDDING_HYBGEN) then + call get_param(param_file, mdl, "USE_HYBGEN_UNMIX", CS%use_hybgen_unmix, & + "If true, use hybgen unmixing code before regridding.", & + default=.false.) + endif + if (coordinateMode(coord_mode) == REGRIDDING_SLIGHT) then ! Set SLight-specific regridding parameters. call get_param(param_file, mdl, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & @@ -744,6 +759,7 @@ subroutine end_regridding(CS) if (associated(CS%hycom_CS)) call end_coord_hycom(CS%hycom_CS) if (associated(CS%slight_CS)) call end_coord_slight(CS%slight_CS) if (associated(CS%adapt_CS)) call end_coord_adapt(CS%adapt_CS) + if (associated(CS%hybgen_CS)) call end_hybgen_regrid(CS%hybgen_CS) deallocate( CS%coordinateResolution ) if (allocated(CS%target_density)) deallocate( CS%target_density ) @@ -816,6 +832,9 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ 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, CS, frac_shelf_h ) + case ( REGRIDDING_HYBGEN ) + call hybgen_regrid(G, GV, G%US, h, tv, CS%hybgen_CS, dzInterface, PCM_cell) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SLIGHT ) call build_grid_SLight( G, GV, G%US, h, tv, dzInterface, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) @@ -835,6 +854,39 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ end subroutine regridding_main +!------------------------------------------------------------------------------ +!> This routine returns flags indicating which pre-remapping state adjustments +!! are needed depending on the coordinate mode in use. +subroutine regridding_preadjust_reqs(CS, do_conv_adj, do_hybgen_unmix, hybgen_CS) + + ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure + logical, intent(out) :: do_conv_adj !< Convective adjustment should be done + logical, intent(out) :: do_hybgen_unmix !< Hybgen unmixing should be done + type(hybgen_regrid_CS), pointer, & + optional, intent(out) :: hybgen_CS !< Control structure for hybgen regridding for sharing parameters. + + + do_conv_adj = .false. ; do_hybgen_unmix = .false. + select case ( CS%regridding_scheme ) + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_SIGMA, REGRIDDING_ARBITRARY, & + REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + do_conv_adj = .false. ; do_hybgen_unmix = .false. + case ( REGRIDDING_RHO ) + do_conv_adj = .true. ; do_hybgen_unmix = .false. + case ( REGRIDDING_HYBGEN ) + do_conv_adj = .false. ; do_hybgen_unmix = CS%use_hybgen_unmix + case default + call MOM_error(FATAL,'MOM_regridding, regridding_preadjust_reqs: '//& + 'Unknown regridding scheme selected!') + end select ! type of grid + + if (present(hybgen_CS) .and. do_hybgen_unmix) hybgen_CS => CS%hybgen_CS + +end subroutine regridding_preadjust_reqs + + !> Calculates h_new from h + delta_k dzInterface subroutine calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1869,14 +1921,17 @@ subroutine convective_adjustment(G, GV, h, tv) !------------------------------------------------------------------------------ ! Local variables - integer :: i, j, k - real :: T0, T1 ! temperatures - real :: S0, S1 ! salinities - real :: r0, r1 ! densities - real :: h0, h1 + real :: T0, T1 ! temperatures of two layers [degC] + real :: S0, S1 ! salinities of two layers [ppt] + real :: r0, r1 ! densities of two layers [R ~> kg m-3] + real :: h0, h1 ! Layer thicknesses [H ~> m or kg m-2] + real, dimension(GV%ke) :: p_col ! A column of zero pressures [R L2 T-2 ~> Pa] + real, dimension(GV%ke) :: densities ! Densities in the column [R ~> kg m-3] logical :: stratified - real, dimension(GV%ke) :: p_col, densities + integer :: i, j, k + !### Doing convective adjustment based on potential densities with zero pressure seems + ! questionable, although it does avoid ambiguous sorting. -RWH p_col(:) = 0. ! Loop on columns @@ -1905,6 +1960,8 @@ subroutine convective_adjustment(G, GV, h, tv) call calculate_density( tv%T(i,j,k), tv%S(i,j,k), p_col(k), densities(k), tv%eqn_of_state) call calculate_density( tv%T(i,j,k+1), tv%S(i,j,k+1), p_col(k+1), & densities(k+1), tv%eqn_of_state ) + ! Because p_col is has uniform values, these calculate_density calls are equivalent to + ! densities(k) = r1 ; densities(k+1) = r0 stratified = .false. endif enddo ! k @@ -1940,8 +1997,8 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) scheme = coordinateMode(coordMode) select case ( scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_SIGMA_SHELF_ZSTAR, & - REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_ADAPTIVE ) uniformResolution(:) = maxDepth / real(nk) case ( REGRIDDING_RHO ) @@ -1960,13 +2017,14 @@ end function uniformResolution !> Initialize the coordinate resolutions by calling the appropriate initialization !! routine for the specified coordinate mode. -subroutine initCoord(CS, GV, US, coord_mode) +subroutine initCoord(CS, GV, US, coord_mode, param_file) type(regridding_CS), intent(inout) :: CS !< Regridding control structure character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode. !! See the documentation for regrid_consts !! for the recognized values. 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 select case (coordinateMode(coord_mode)) case (REGRIDDING_ZSTAR) @@ -1980,6 +2038,8 @@ subroutine initCoord(CS, GV, US, coord_mode) case (REGRIDDING_HYCOM1) call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, & CS%interp_CS) + case (REGRIDDING_HYBGEN) + call init_hybgen_regrid(CS%hybgen_CS, GV, US, param_file) case (REGRIDDING_SLIGHT) call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & CS%interp_CS, GV%m_to_H) @@ -2121,6 +2181,11 @@ subroutine write_regrid_file( CS, GV, filepath ) type(file_type) :: IO_handle ! The I/O handle of the fileset real :: ds(GV%ke), dsi(GV%ke+1) + if (CS%regridding_scheme == REGRIDDING_HYBGEN) then + call write_Hybgen_coord_file(GV, CS%hybgen_CS, filepath) + return + endif + ds(:) = CS%coord_scale * CS%coordinateResolution(:) dsi(1) = 0.5*ds(1) dsi(2:GV%ke) = 0.5*( ds(1:GV%ke-1) + ds(2:GV%ke) ) @@ -2209,7 +2274,8 @@ function getCoordinateUnits( CS ) character(len=20) :: getCoordinateUnits select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + REGRIDDING_ADAPTIVE ) getCoordinateUnits = 'meter' case ( REGRIDDING_SIGMA_SHELF_ZSTAR ) getCoordinateUnits = 'meter/fraction' @@ -2247,6 +2313,8 @@ function getCoordinateShortName( CS ) getCoordinateShortName = 'coordinate' case ( REGRIDDING_HYCOM1 ) getCoordinateShortName = 'z-rho' + case ( REGRIDDING_HYBGEN ) + getCoordinateShortName = 'hybrid' case ( REGRIDDING_SLIGHT ) getCoordinateShortName = 's-rho' case ( REGRIDDING_ADAPTIVE ) @@ -2341,6 +2409,8 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri case (REGRIDDING_HYCOM1) if (associated(CS%hycom_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & call set_hycom_params(CS%hycom_CS, interp_CS=CS%interp_CS) + case (REGRIDDING_HYBGEN) + ! Do nothing for now. case (REGRIDDING_SLIGHT) if (present(min_thickness)) call set_slight_params(CS%slight_CS, min_thickness=min_thickness) if (present(dz_min_surface)) call set_slight_params(CS%slight_CS, dz_ml_min=dz_min_surface) @@ -2409,7 +2479,8 @@ function getStaticThickness( CS, SSH, depth ) real :: z, dz select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & + REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) if (depth>0.) then z = ssh do k = 1, CS%nk diff --git a/src/ALE/regrid_consts.F90 b/src/ALE/regrid_consts.F90 index 7e8edea344..9fe638dd5b 100644 --- a/src/ALE/regrid_consts.F90 +++ b/src/ALE/regrid_consts.F90 @@ -21,6 +21,7 @@ module regrid_consts integer, parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR = 8 !< Identifiered for z* coordinates at the bottom, !! sigma-near the top integer, parameter :: REGRIDDING_ADAPTIVE = 9 !< Adaptive coordinate mode identifier +integer, parameter :: REGRIDDING_HYBGEN = 10 !< Hybgen coordinates identifier character(len=*), parameter :: REGRIDDING_LAYER_STRING = "LAYER" !< Layer string character(len=*), parameter :: REGRIDDING_ZSTAR_STRING_OLD = "Z*" !< z* string (legacy name) @@ -29,6 +30,7 @@ module regrid_consts character(len=*), parameter :: REGRIDDING_SIGMA_STRING = "SIGMA" !< Sigma string character(len=*), parameter :: REGRIDDING_ARBITRARY_STRING = "ARB" !< Arbitrary coordinates character(len=*), parameter :: REGRIDDING_HYCOM1_STRING = "HYCOM1" !< Hycom string +character(len=*), parameter :: REGRIDDING_HYBGEN_STRING = "HYBGEN" !< Hybgen string character(len=*), parameter :: REGRIDDING_SLIGHT_STRING = "SLIGHT" !< Hybrid S-rho string character(len=*), parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR_STRING = "SIGMA_SHELF_ZSTAR" !< Hybrid z*/sigma character(len=*), parameter :: REGRIDDING_ADAPTIVE_STRING = "ADAPTIVE" !< Adaptive coordinate string @@ -60,6 +62,7 @@ function coordinateMode(string) case (trim(REGRIDDING_RHO_STRING)); coordinateMode = REGRIDDING_RHO case (trim(REGRIDDING_SIGMA_STRING)); coordinateMode = REGRIDDING_SIGMA case (trim(REGRIDDING_HYCOM1_STRING)); coordinateMode = REGRIDDING_HYCOM1 + case (trim(REGRIDDING_HYBGEN_STRING)); coordinateMode = REGRIDDING_HYBGEN case (trim(REGRIDDING_SLIGHT_STRING)); coordinateMode = REGRIDDING_SLIGHT case (trim(REGRIDDING_ARBITRARY_STRING)); coordinateMode = REGRIDDING_ARBITRARY case (trim(REGRIDDING_SIGMA_SHELF_ZSTAR_STRING)); coordinateMode = REGRIDDING_SIGMA_SHELF_ZSTAR @@ -81,6 +84,7 @@ function coordinateUnitsI(coordMode) case (REGRIDDING_RHO); coordinateUnitsI = "kg m^-3" case (REGRIDDING_SIGMA); coordinateUnitsI = "Non-dimensional" case (REGRIDDING_HYCOM1); coordinateUnitsI = "m" + case (REGRIDDING_HYBGEN); coordinateUnitsI = "m" case (REGRIDDING_SLIGHT); coordinateUnitsI = "m" case (REGRIDDING_ADAPTIVE); coordinateUnitsI = "m" case default ; call MOM_error(FATAL, "coordinateUnts: "//& @@ -116,6 +120,7 @@ logical function state_dependent_int(mode) case (REGRIDDING_RHO); state_dependent_int = .true. case (REGRIDDING_SIGMA); state_dependent_int = .false. case (REGRIDDING_HYCOM1); state_dependent_int = .true. + case (REGRIDDING_HYBGEN); state_dependent_int = .true. case (REGRIDDING_SLIGHT); state_dependent_int = .true. case (REGRIDDING_ADAPTIVE); state_dependent_int = .true. case default ; call MOM_error(FATAL, "state_dependent: "//& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4e8dd4f186..83f0b618c2 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -88,12 +88,10 @@ module MOM_state_initialization use dumbbell_initialization, only : dumbbell_initialize_sponges use MOM_tracer_Z_init, only : tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord -use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated -use MOM_ALE, only : TS_PLM_edge_values +use MOM_ALE, only : ALE_remap_scalar, ALE_regrid_accelerated, TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution -use MOM_regridding, only : regridding_main -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : remapping_core_h +use MOM_regridding, only : regridding_main, regridding_preadjust_reqs, convective_adjustment +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer use MOM_oda_incupd, only: oda_incupd_CS, initialize_oda_incupd_fixed, initialize_oda_incupd use MOM_oda_incupd, only: set_up_oda_incupd_field, set_up_oda_incupd_vel_field @@ -212,7 +210,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & use_EOS = associated(tv%eqn_of_state) use_OBC = associated(OBC) if (use_EOS) eos => tv%eqn_of_state - use_ice_shelf=PRESENT(frac_shelf_h) + use_ice_shelf = PRESENT(frac_shelf_h) !==================================================================== ! Initialize temporally evolving fields, either as initial @@ -2439,18 +2437,21 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! data arrays real, dimension(:), allocatable :: z_edges_in, z_in ! Interface heights [Z ~> m] real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] - real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z + real, dimension(:,:,:), allocatable, target :: temp_z ! Input temperatures [degC] + real, dimension(:,:,:), allocatable, target :: salt_z ! Input salinities [ppt] + real, dimension(:,:,:), allocatable, target :: mask_z ! 1 for valid data points [nondim] real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zi ! Interface heights [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: Z_bottom ! The (usually negative) height of the seafloor ! relative to the surface [Z ~> m]. - integer, dimension(SZI_(G),SZJ_(G)) :: nlevs + integer, dimension(SZI_(G),SZJ_(G)) :: nlevs ! The number of levels in each column with valid data real, dimension(SZI_(G)) :: press ! Pressures [R L2 T-2 ~> Pa]. ! Local variables for ALE remapping real, dimension(:), allocatable :: hTarget ! Target thicknesses [Z ~> m]. - real, dimension(:,:,:), allocatable, target :: tmpT1dIn, tmpS1dIn - real, dimension(:,:,:), allocatable :: tmp_mask_in + real, dimension(:,:,:), allocatable, target :: tmpT1dIn ! Input temperatures on a model-sized grid [degC] + real, dimension(:,:,:), allocatable, target :: tmpS1dIn ! Input salinities on a model-sized grid [ppt] + real, dimension(:,:,:), allocatable :: tmp_mask_in ! The valid data mask on a model-sized grid [nondim] real, dimension(:,:,:), allocatable :: h1 ! Thicknesses [H ~> m or kg m-2]. real, dimension(:,:,:), allocatable :: dz_interface ! Change in position of interface due to regridding real :: zTopOfCell, zBottomOfCell ! Heights in Z units [Z ~> m]. @@ -2459,7 +2460,6 @@ 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 logical :: answers_2018, default_2018_answers, hor_regrid_answers_2018 - logical :: use_ice_shelf logical :: pre_gridded logical :: separate_mixed_layer ! If true, handle the mixed layers differently. logical :: density_extrap_bug ! If true use an expression with a vertical indexing bug for @@ -2467,7 +2467,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! from data when finding the initial interface locations in ! layered mode from a dataset of T and S. character(len=64) :: remappingScheme - real :: tempAvg, saltAvg + real :: tempAvg ! Spatially averaged temperatures on a layer [degC] + real :: saltAvg ! Spatially averaged salinities on a layer [ppt] + logical :: do_conv_adj, ignore integer :: nPoints, ans integer :: id_clock_routine, id_clock_read, id_clock_interp, id_clock_fill, id_clock_ALE @@ -2493,8 +2495,6 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x, default=.true.) tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) - use_ice_shelf = present(frac_shelf_h) - call get_param(PF, mdl, "TEMP_SALT_Z_INIT_FILE", filename, & "The name of the z-space input file used to initialize "//& "temperatures (T) and salinities (S). If T and S are not "//& @@ -2722,11 +2722,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just GV_loc = GV GV_loc%ke = nkd allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used - if (use_ice_shelf) then - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, frac_shelf_h ) - else - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface ) - endif + + 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, frac_shelf_h, & + conv_adjust=.false. ) + deallocate( dz_interface ) endif call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & From 6ff5098e92129533369a15a0fbb44c3cdbd5f7ad Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Apr 2022 12:21:01 -0400 Subject: [PATCH 03/10] +Convective adjustment outside regridding_main Eliminated the option to do convective adjustment within regridding_main, including making the optional argument conv_adjust mandatory, with an error message if it is set to .true., so that there will not be the possibility of this code change silently changing the code behavior or solutions. After a decent interval, this argument can be safely eliminated. As a result of these changes, the intent of two key arguments to regridding_main() could be changed from intent(inout) to intent(in), which should help clarify the purpose of this routine. All answers are bitwise identical, but there are interface changes. --- src/ALE/MOM_ALE.F90 | 4 ++-- src/ALE/MOM_regridding.F90 | 24 ++++++++++++------- .../MOM_state_initialization.F90 | 4 ++-- 3 files changed, 19 insertions(+), 13 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 97303aa100..876c2c684b 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -426,8 +426,8 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) ! Build new grid. The new grid is stored in h_new. The old grid is h. ! Both are needed for the subsequent remapping of variables. - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, & - frac_shelf_h, conv_adjust=.false., PCM_cell=PCM_cell) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust=.false., & + frac_shelf_h=frac_shelf_h, PCM_cell=PCM_cell) call check_grid( G, GV, h, 0. ) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index e7680df0c2..78159146a2 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -770,8 +770,8 @@ end subroutine end_regridding !------------------------------------------------------------------------------ !> Dispatching regridding routine for orchestrating regridding & remapping -subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_shelf_h, & - conv_adjust, PCM_cell) +subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, conv_adjust, & + frac_shelf_h, PCM_cell) !------------------------------------------------------------------------------ ! This routine takes care of (1) building a new grid and (2) remapping between ! the old grid and the new grid. The creation of the new grid can be based @@ -794,22 +794,29 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ 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(inout) :: h !< Current 3D grid obtained after + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after !! the last time step - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variables (T, S, ...) + 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 + logical, intent(in ) :: conv_adjust !< If true, regridding_main should do + !! convective adjustment, but because it no + !! longer does convective adjustment this must + !! be false. This argument has been retained to + !! trap inconsistent code, but will eventually + !! be eliminated. real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage - logical, optional, intent(in ) :: conv_adjust !< If true, do convective adjustment logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out ) :: PCM_cell !< Use PCM remapping in cells where true ! Local variables real :: trickGnuCompiler - logical :: do_convective_adjustment - do_convective_adjustment = .true. - if (present(conv_adjust)) do_convective_adjustment = conv_adjust + if (conv_adjust) call MOM_error(FATAL, & + "regridding_main: convective adjustment no longer is done inside of regridding_main. "//& + "The code needs to be modified to call regridding_main() with conv_adjust=.false, "//& + "and a call to convective_adjustment added before calling regridding_main() "//& + "if regridding_preadjust_reqs() indicates that this is necessary.") if (present(PCM_cell)) PCM_cell(:,:,:) = .false. select case ( CS%regridding_scheme ) @@ -824,7 +831,6 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ call build_sigma_grid( CS, G, GV, h, dzInterface ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_RHO ) - if (do_convective_adjustment) call convective_adjustment(G, GV, h, tv) call build_rho_grid( G, GV, G%US, h, tv, dzInterface, remapCS, CS, frac_shelf_h ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ARBITRARY ) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 83f0b618c2..ee3052f166 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2725,8 +2725,8 @@ 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, frac_shelf_h, & - conv_adjust=.false. ) + call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, conv_adjust=.false., & + frac_shelf_h=frac_shelf_h ) deallocate( dz_interface ) endif From 1b0533d06984aebca4320f96d7d5810beed08585 Mon Sep 17 00:00:00 2001 From: He Wang <35150900+herrwang0@users.noreply.github.com> Date: Sun, 10 Apr 2022 11:35:28 -0400 Subject: [PATCH 04/10] Fix tides_CS attribute in unsplit mode (#103) Remove the pointer attribute from tides_CS in its parent CS in unsplit mode. This recovers tidal forcing functionality in the unsplit mode. --- src/core/MOM_dynamics_unsplit.F90 | 2 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 9a58dddd0f..085b4e02c3 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -154,7 +154,7 @@ module MOM_dynamics_unsplit !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() !> A pointer to the tidal forcing control structure - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index ec4a1aa843..91aaca508e 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -156,7 +156,7 @@ module MOM_dynamics_unsplit_RK2 !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() !> A pointer to the tidal forcing control structure - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() From 4c017ad0da791bed23207ac5c0ccb35fa13b2c06 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Sun, 10 Apr 2022 12:06:39 -0400 Subject: [PATCH 05/10] Correct --with-driver args for coupled tests (#106) - Ever since a renaming of driver directories, the tests under "test-top-api", that are meant to check we are compatible with each "cap", have been failing silently. - This fixes the wrong arguments but does not fix the ability to fail silently which is somewhere deep inside mkmf. --- .testing/Makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index f330c92e3b..4096436f30 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -265,9 +265,9 @@ 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=coupled_driver -build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_driver -build/mct/Makefile: MOM_ACFLAGS=--with-driver=mct_driver +build/coupled/Makefile: MOM_ACFLAGS=--with-driver=FMS_cap +build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_cap +build/mct/Makefile: MOM_ACFLAGS=--with-driver=mct_cap # Fetch regression target source code build/target/Makefile: | $(TARGET_CODEBASE) From 698676c56b26b2576670ecad78fed9f42108dcde Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Apr 2022 18:33:38 -0400 Subject: [PATCH 06/10] Standardized syntax in mask2d logical tests Modified the syntax of the logical comparisons with the various mask2d variables to always check whether they are larger than 0.0, not 0.5 and use similar syntax throughout the MOM6 code. Because these arrays are always either 0.0 or 1.0, the answers are bitwise identical. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 22 ++++++------ .../mct_cap/mom_surface_forcing_mct.F90 | 18 +++++----- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 18 +++++----- .../solo_driver/MESO_surface_forcing.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 12 +++---- src/ALE/coord_adapt.F90 | 8 ++--- src/core/MOM_forcing_type.F90 | 16 ++++----- src/diagnostics/MOM_wave_speed.F90 | 4 +-- src/diagnostics/MOM_wave_structure.F90 | 6 ++-- .../vertical/MOM_ALE_sponge.F90 | 24 ++++++------- .../vertical/MOM_diabatic_aux.F90 | 10 +++--- .../vertical/MOM_diapyc_energy_req.F90 | 2 +- .../vertical/MOM_energetic_PBL.F90 | 2 +- .../vertical/MOM_entrain_diffusive.F90 | 2 +- .../vertical/MOM_internal_tide_input.F90 | 2 +- .../vertical/MOM_kappa_shear.F90 | 2 +- .../vertical/MOM_opacity.F90 | 10 +++--- .../vertical/MOM_set_diffusivity.F90 | 26 +++++++------- .../vertical/MOM_set_viscosity.F90 | 6 ++-- src/parameterizations/vertical/MOM_sponge.F90 | 4 +-- .../vertical/MOM_vert_friction.F90 | 12 +++---- src/tracer/MOM_generic_tracer.F90 | 2 +- src/tracer/MOM_neutral_diffusion.F90 | 10 +++--- src/tracer/MOM_offline_aux.F90 | 10 +++--- src/tracer/MOM_tracer_diabatic.F90 | 36 +++++++++---------- src/tracer/MOM_tracer_hor_diff.F90 | 18 +++++----- src/tracer/boundary_impulse_tracer.F90 | 2 +- src/tracer/ideal_age_example.F90 | 2 +- 28 files changed, 143 insertions(+), 145 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 acbbc292de..faa74a7fe0 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -374,7 +374,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & @@ -956,13 +956,13 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux).and.present(tauy)) then do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & taux(I,j) = (G%mask2dBu(I,J)*taux_in_B(I,J) + G%mask2dBu(I,J-1)*taux_in_B(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo ; enddo do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & tauy(i,J) = (G%mask2dBu(I,J)*tauy_in_B(I,J) + G%mask2dBu(I-1,J)*tauy_in_B(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo ; enddo @@ -984,14 +984,14 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & taux(I,j) = (G%mask2dT(i,j)*taux_in_A(i,j) + G%mask2dT(i+1,j)*taux_in_A(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo ; enddo ; endif if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & tauy(i,J) = (G%mask2dT(i,j)*tauy_in_A(i,j) + G%mask2dT(i,J+1)*tauy_in_A(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo ; enddo ; endif @@ -1029,10 +1029,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, gustiness = CS%gust_const if (CS%read_gust_2d) then if ((wind_stagger == CGRID_NE) .or. & - ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0)) .or. & + ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0.0)) .or. & ((wind_stagger == BGRID_NE) .and. & (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0)) ) & gustiness = CS%gust(i,j) endif ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*Pa_conversion*IOB%stress_mag(i-i0,j-j0)) @@ -1050,7 +1050,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_in_B(I,J)**2 + tauy_in_B(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_in_B(I-1,J-1)**2 + tauy_in_B(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_in_B(I,J-1)**2 + tauy_in_B(I,J-1)**2) + & @@ -1069,7 +1069,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, do j=js,je ; do i=is,ie tau_mag = G%mask2dT(i,j) * sqrt(taux_in_A(i,j)**2 + tauy_in_A(i,j)**2) gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (CS%answers_2018) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) @@ -1080,10 +1080,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, else ! C-grid wind stresses. do j=js,je ; do i=is,ie taux2 = 0.0 ; tauy2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*taux_in_C(I-1,j)**2 + G%mask2dCu(I,j)*taux_in_C(I,j)**2) / & (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*tauy_in_C(i,J-1)**2 + G%mask2dCv(i,J)*tauy_in_C(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) tau_mag = sqrt(taux2 + tauy2) 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 7b32270b4c..a8a3ea0c69 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -385,7 +385,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & @@ -749,7 +749,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) @@ -757,7 +757,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) @@ -770,7 +770,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & @@ -786,7 +786,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) @@ -794,7 +794,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) @@ -802,7 +802,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo; enddo @@ -814,12 +814,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) 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 c704214930..d04ecf10e4 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -410,7 +410,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & @@ -806,7 +806,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) @@ -814,7 +814,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) @@ -827,7 +827,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & @@ -843,7 +843,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) @@ -851,7 +851,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) @@ -859,7 +859,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo ; enddo @@ -871,12 +871,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 index 300c736802..9c67be4829 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -172,7 +172,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) fluxes%vprec(i,j) = - (CS%Rho0 * CS%Flux_const) * & diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 7c26c2f194..7bca03ca5d 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1125,7 +1125,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & @@ -1138,7 +1138,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else @@ -1231,7 +1231,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (CS%restorebuoy) then if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & @@ -1244,7 +1244,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else @@ -1431,7 +1431,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & @@ -1446,7 +1446,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then + ! if (G%mask2dT(i,j) > 0.0) then ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & ! (CS%G_Earth * CS%Flux_const / CS%Rho0) ! else diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index fe3864fc7a..e5b33103ef 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -154,7 +154,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex ! TODO: this needs to be adjusted to account for vanished layers near topography ! up (j-1) - if (G%mask2dT(i,j-1) > 0.) then + if (G%mask2dT(i,j-1) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j-1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j-1,2:nz)), & @@ -166,7 +166,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i,j-1,2:nz) - sInt(i,j,2:nz))) endif ! down (j+1) - if (G%mask2dT(i,j+1) > 0.) then + if (G%mask2dT(i,j+1) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j+1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j+1,2:nz)), & @@ -178,7 +178,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i,j+1,2:nz) - sInt(i,j,2:nz))) endif ! left (i-1) - if (G%mask2dT(i-1,j) > 0.) then + if (G%mask2dT(i-1,j) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i-1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i-1,j,2:nz)), & @@ -190,7 +190,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i-1,j,2:nz) - sInt(i,j,2:nz))) endif ! right (i+1) - if (G%mask2dT(i+1,j) > 0.) then + if (G%mask2dT(i+1,j) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i+1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i+1,j,2:nz)), & diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index ccd70cd9da..6de46f7738 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2184,12 +2184,12 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) associated(fluxes%ustar_gustless)) then do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j) * forces%taux(I-1,j)**2 + & G%mask2dCu(I,j) * forces%taux(I,j)**2) / & (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1) * forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) @@ -3518,15 +3518,15 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) if (do_stress) then tx_mean = global_area_mean_u(forces%taux, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) do j=js,je ; do i=isB,ieB - if (G%mask2dCu(I,j) > 0.) forces%taux(I,j) = tx_mean + if (G%mask2dCu(I,j) > 0.0) forces%taux(I,j) = tx_mean enddo ; enddo ty_mean = global_area_mean_v(forces%tauy, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,J) > 0.) forces%tauy(i,J) = ty_mean + 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.) forces%ustar(i,j) = sqrt(sqrt(tx_mean**2 + ty_mean**2)*Irho0) + if (G%mask2dT(i,j) > 0.0) forces%ustar(i,j) = sqrt(sqrt(tx_mean**2 + ty_mean**2)*Irho0) enddo ; enddo else call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) @@ -3689,7 +3689,7 @@ subroutine homogenize_field_t(var, G, tmp_scale) avg = global_area_mean(var, G, tmp_scale=tmp_scale) do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.) var(i,j) = avg + if (G%mask2dT(i,j) > 0.0) var(i,j) = avg enddo ; enddo end subroutine homogenize_field_t @@ -3706,7 +3706,7 @@ subroutine homogenize_field_v(var, G, tmp_scale) avg = global_area_mean_v(var, G, tmp_scale=tmp_scale) do J=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,J) > 0.) var(i,J) = avg + if (G%mask2dCv(i,J) > 0.0) var(i,J) = avg enddo ; enddo end subroutine homogenize_field_v @@ -3723,7 +3723,7 @@ subroutine homogenize_field_u(var, G, tmp_scale) avg = global_area_mean_u(var, G, tmp_scale=tmp_scale) do j=js,je ; do I=isB,ieB - if (G%mask2dCu(I,j) > 0.) var(I,j) = avg + if (G%mask2dCu(I,j) > 0.0) var(I,j) = avg enddo ; enddo end subroutine homogenize_field_u diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 0f3b19f2e1..50933abe07 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -262,7 +262,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ endif ! From this point, we can work on individual columns without causing memory to have page faults. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) @@ -815,7 +815,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! From this point, we can work on individual columns without causing memory to have page faults. do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index c833e973c5..81c8799828 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -272,12 +272,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! From this point, we can work on individual columns without causing memory ! to have page faults. - do i=is,ie ; if (cn(i,j)>0.0)then + do i=is,ie ; if (cn(i,j) > 0.0) then !----for debugging, remove later---- ig = i + G%idg_offset ; jg = j + G%jdg_offset !if (ig == CS%int_tide_source_x .and. jg == CS%int_tide_source_y) then !----------------------------------- - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then gprime(:) = 0.0 ! init gprime pres(:) = 0.0 ! init pres @@ -567,7 +567,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo !else ! if at test point - delete later ! return ! if at test point - delete later !endif ! if at test point - delete later - endif ! mask2dT > 0.5? + endif ! mask2dT > 0.0? else ! if cn=0.0, default to zero nzm = nz+1! could use actual values diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index f711ef3f87..446cdb8b45 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -230,7 +230,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! number of columns to be restored CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo @@ -241,7 +241,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 @@ -282,7 +282,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, enddo ; enddo endif do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & CS%num_col_u = CS%num_col_u + 1 enddo ; enddo @@ -295,7 +295,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! Store the column indices and restoring rates in the CS structure col = 1 do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) then CS%col_i_u(col) = I ; CS%col_j_u(col) = j CS%Iresttime_col_u(col) = Iresttime_u(I,j) col = col + 1 @@ -326,7 +326,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, enddo ; enddo endif do J=G%jscB,G%jecB; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo @@ -339,7 +339,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! pass indices, restoring time to the CS structure col = 1 do J=G%jscB,G%jecB ; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col + 1 @@ -492,7 +492,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! number of columns to be restored CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo if (CS%num_col > 0) then @@ -502,7 +502,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col + 1 @@ -532,7 +532,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest endif CS%num_col_u = 0 ; do j=G%jsc,G%jec; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & CS%num_col_u = CS%num_col_u + 1 enddo ; enddo if (CS%num_col_u > 0) then @@ -542,7 +542,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) then CS%col_i_u(col) = i ; CS%col_j_u(col) = j CS%Iresttime_col_u(col) = Iresttime_u(i,j) col = col + 1 @@ -564,7 +564,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest endif CS%num_col_v = 0 ; do J=G%jscB,G%jecB; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo if (CS%num_col_v > 0) then @@ -574,7 +574,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do J=G%jscB,G%jecB ; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col + 1 diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 6f1988c295..7aec4c0331 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -527,7 +527,7 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) do j=js,je do i=is,ie sum_area = G%areaCu(I-1,j) + G%areaCu(I,j) - if (sum_area>0.0) then + if (sum_area > 0.0) then Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) a_w(i) = G%areaCu(I-1,j) * Idenom a_e(i) = G%areaCu(I,j) * Idenom @@ -536,7 +536,7 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) endif sum_area = G%areaCv(i,J-1) + G%areaCv(i,J) - if (sum_area>0.0) then + if (sum_area > 0.0) then Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) a_s(i) = G%areaCv(i,J-1) * Idenom a_n(i) = G%areaCv(i,J) * Idenom @@ -618,7 +618,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow ! same value is assumed for all layers. call time_interp_external(CS%sbc_chl, CS%Time, chl_2d) do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_2d(i,j) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Time_interp negative chl of ",(1pe12.4)," at i,j = ",& & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_2d(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) @@ -768,7 +768,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! endif 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.5) .and. N2_region_set(i)) then + 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)) endif ; enddo endif @@ -1227,7 +1227,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t else netMassIn(i) = netMassInOut(i) - netMassOut(i) endif - if (G%mask2dT(i,j)>0.0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%netMassOut(i,j) = netMassOut(i) fluxes%netMassIn(i,j) = netMassIn(i) else diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 379275196e..eb592fb890 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -81,7 +81,7 @@ 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.5) then + 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 diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 99dd38135d..98ab99616f 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -390,7 +390,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! homogenizing the shortwave heating within that cell. This sets the energy ! and ustar and wstar available to drive mixing at the first interior ! interface. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! Copy the thicknesses and other fields to 1-d arrays. do k=1,nz diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index fdc38ebf1e..45d442f98c 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -288,7 +288,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & enddo ; enddo endif - do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do i=is,ie ; ds_dsp1(i,nz) = 0.0 ; enddo do i=is,ie ; dsp1_ds(i,nz) = 0.0 ; enddo diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 300cdcbe1e..7af12aee6f 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -253,7 +253,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) 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) - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) h_amp(i) = sqrt(h2(i,j)) enddo diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index a44a7aee95..8af8727246 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -197,7 +197,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & !--------------------------------------- ! Work on each column. !--------------------------------------- - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + 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. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 9aa8fafd14..66b7a7746e 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -290,7 +290,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir if (present(chl_3d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_3d(i,j,1) ; enddo ; enddo do k=1,nz ; do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_3d(i,j,k) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_3d(i,j,k) < 0.0)) then write(mesg,'(" Negative chl_3d of ",(1pe12.4)," found at i,j,k = ", & & 3(1x,i3), " lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_3d(i,j,k), i, j, k, G%geoLonT(i,j), G%geoLatT(i,j) @@ -300,7 +300,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir elseif (present(chl_2d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_2d(i,j) ; enddo ; enddo do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_2d(i,j) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Negative chl_2d of ",(1pe12.4)," at i,j = ", & & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_data(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) @@ -316,7 +316,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir !$OMP parallel do default(shared) private(SW_vis_tot,SW_nir_tot) do j=js,je ; do i=is,ie SW_vis_tot = 0.0 ; SW_nir_tot = 0.0 - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (multiband_vis_input) then SW_vis_tot = sw_vis_dir(i,j) + sw_vis_dif(i,j) elseif (total_sw_input) then @@ -344,7 +344,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir !$OMP parallel do default(shared) private(SW_pen_tot) do j=js,je ; do i=is,ie SW_pen_tot = 0.0 - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (multiband_vis_input) then SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * (sw_vis_dir(i,j) + sw_vis_dif(i,j)) elseif (total_sw_input) then @@ -385,7 +385,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir case (MOREL_88) do j=js,je ; do i=is,ie optics%opacity_band(1,i,j,k) = CS%opacity_land_value - if (G%mask2dT(i,j) > 0.5) & + if (G%mask2dT(i,j) > 0.0) & optics%opacity_band(1,i,j,k) = US%Z_to_m * opacity_morel(chl_data(i,j)) do n=2,optics%nbands diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 061fe776e1..0d5f1a9ca9 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -503,7 +503,7 @@ 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%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) @@ -812,7 +812,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & do i=is,ie htot(i) = GV%H_to_Z*(h(i,j,nz) - GV%Angstrom_H) ; maxEnt(i,nz) = 0.0 - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz-1,kb_min,-1 i_rem = 0 @@ -969,7 +969,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & 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) - do_i(i) = (G%mask2dT(i,j) > 0.5) + 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) @@ -1001,7 +1001,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & 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) - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz,2,-1 @@ -1195,7 +1195,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & do_diag_Kd_BBL = associated(Kd_BBL) - if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic>0.0))) return + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return cdrag_sqrt = sqrt(CS%cdrag) TKE_Ray = 0.0 ; Rayleigh_drag = .false. @@ -1238,7 +1238,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & gh_sum_top(i) = R0_g * 400.0 * ustar_h**2 - do_i(i) = (G%mask2dT(i,j) > 0.5) + 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)) Rho_top(i) = GV%Rlay(1) @@ -1259,7 +1259,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & if (.not.domore) exit enddo ! k-loop - do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do k=nz-1,kb_min,-1 i_rem = 0 do i=is,ie ; if (do_i(i)) then @@ -1409,7 +1409,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real, parameter :: von_karm = 0.41 ! Von Karman constant (http://en.wikipedia.org/wiki/Von_Karman_constant) logical :: do_diag_Kd_BBL - if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic>0.0))) return + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return do_diag_Kd_BBL = associated(Kd_BBL) N2_min = 0. @@ -1568,7 +1568,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, if (.not.CS%ML_radiation) return - do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + 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 i=is,ie ; if (do_i(i)) then @@ -1734,7 +1734,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) ! Determine ustar and the square magnitude of the velocity in the ! bottom boundary layer. Together these give the TKE source and ! vertical decay scale. - do i=is,ie ; if ((G%mask2dCv(i,J) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) 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. ; vhtot(i) = 0.0 ; htot(i) = 0.0 vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) else @@ -1775,7 +1775,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo if (.not.domore) exit enddo - do i=is,ie ; if ((G%mask2dCv(i,J) > 0.5) .and. (htot(i) > 0.0)) then + 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)) else v2_bbl(i,J) = 0.0 @@ -1783,7 +1783,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) enddo !$OMP do do j=js,je - do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) 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. ; uhtot(I) = 0.0 ; htot(I) = 0.0 ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) else @@ -1823,7 +1823,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo if (.not.domore) exit enddo - do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (htot(i) > 0.0)) then + 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)) else u2_bbl(I) = 0.0 diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 92e7b44128..93a71f6b64 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -385,15 +385,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (j 0) do_i(i) = .true. + do_i(i) = (G%mask2dCu(I,j) > 0.0) enddo else ! m=2 refers to v-points is = G%isc ; ie = G%iec do i=is,ie - do_i(i) = .false. - if (G%mask2dCv(i,J) > 0) do_i(i) = .true. + do_i(i) = (G%mask2dCv(i,J) > 0.0) enddo endif diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index d0d64079c3..dee80b9e40 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -131,7 +131,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo @@ -143,7 +143,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d384500c3d..d6c93a5211 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -256,7 +256,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & !$OMP b_denom_1,b1,d1,c1) do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq @@ -383,7 +383,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & !$OMP b_denom_1,b1,d1,c1) do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie @@ -593,7 +593,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (CS%Channel_drag) then ; do k=1,nz ; do I=Isq,Ieq Ray(I,k) = visc%Ray_u(I,j,k) @@ -622,7 +622,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Now find the meridional viscous remnant using the robust tridiagonal solver. !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (CS%Channel_drag) then ; do k=1,nz ; do i=is,ie Ray(i,k) = visc%Ray_v(i,J,k) @@ -766,7 +766,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) !$OMP OBC,h_neglect,dt,I_valBL,Kv_u,a_cpl_max) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + 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) @@ -931,7 +931,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) !$OMP OBC,h_neglect,dt,I_valBL,Kv_v,a_cpl_max) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + 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) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 31acb51160..5e8632f1ca 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -361,7 +361,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, grid_tmask(:,:,:) = 0.0 grid_kmt(:,:) = 0 do j = G%jsd, G%jed ; do i = G%isd, G%ied - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then grid_tmask(i,j,:) = 1.0 grid_kmt(i,j) = GV%ke ! Tell the code that a layer thicker than 1m is the bottom layer. endif diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 61715e044b..08361ba9af 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -325,7 +325,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) call pass_var(hbl,G%Domain) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 - if (G%mask2dT(i,j) > 0.) then + if (G%mask2dT(i,j) > 0.0) then call boundary_k_range(SURFACE, G%ke, h(i,j,:), hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) endif enddo; enddo @@ -463,7 +463,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Neutral surface factors at U points do j = G%jsc, G%jec ; do I = G%isc-1, G%iec - if (G%mask2dCu(I,j) > 0.) then + if (G%mask2dCu(I,j) > 0.0) then if (CS%continuous_reconstruction) then call find_neutral_surface_positions_continuous(GV%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & @@ -484,7 +484,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Neutral surface factors at V points do J = G%jsc-1, G%jec ; do i = G%isc, G%iec - if (G%mask2dCv(i,J) > 0.) then + if (G%mask2dCv(i,J) > 0.0) then if (CS%continuous_reconstruction) then call find_neutral_surface_positions_continuous(GV%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & @@ -519,10 +519,10 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) enddo ; enddo ; enddo else do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec - if (G%mask2dCu(I,j) > 0.) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H + if (G%mask2dCu(I,j) > 0.0) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H enddo ; enddo ; enddo do k = 1, CS%nsurf-1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec - if (G%mask2dCv(i,J) > 0.) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H + if (G%mask2dCv(i,J) > 0.0) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H enddo ; enddo ; enddo endif endif diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index bdd6be4fe0..fdf199d71e 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -179,7 +179,7 @@ subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) (max(0.0, -vh(i,J-1,k)) + max(0.0, vh(i,J,k)))) + & (max(0.0, top_flux(i,j,k)) + max(0.0, bottom_flux(i,j,k))) * G%areaT(i,j) - if (pos_flux>hvol .and. pos_flux>0.0) then + if ((pos_flux > hvol) .and. (pos_flux > 0.0)) then scale_factor = (hvol / pos_flux) * max_off_cfl else ! Don't scale scale_factor = 1.0 @@ -405,7 +405,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) do k=1,nz uh_remain = uh2d(I,k) uh2d(I,k) = 0.0 - if (abs(uh_remain)>0.0) then + if (abs(uh_remain) > 0.0) then do k_rev = k,1,-1 uh_sum = uh_remain + uh2d(I,k_rev) if (uh_sum<0.0) then ! Transport to the left @@ -436,7 +436,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) enddo ! k_rev endif - if (abs(uh_remain)>0.0) then + if (abs(uh_remain) > 0.0) then if (k0.0) then + if (abs(vh_remain) > 0.0) then do k_rev = k,1,-1 vh_sum = vh_remain + vh2d(J,k_rev) if (vh_sum<0.0) then ! Transport to the left @@ -535,7 +535,7 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) enddo ! k_rev endif - if (abs(vh_remain)>0.0) then + if (abs(vh_remain) > 0.0) then if (k 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then b_denom_1 = h_minus_dsink(i,1) + ea(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) d1(i) = b_denom_1 * b1(i) h_tr = h_old(i,j,1) + h_neglect tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = eb(i,j,k-1) * b1(i) b_denom_1 = h_minus_dsink(i,k) + d1(i) * (ea(i,j,k) + sink(i,K)) + & h_neglect @@ -164,7 +164,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + & (ea(i,j,k) + sink(i,K)) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = eb(i,j,nz-1) * b1(i) b_denom_1 = h_minus_dsink(i,nz) + d1(i) * (ea(i,j,nz) + sink(i,nz)) + & h_neglect @@ -173,25 +173,25 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * ((h_tr * tr(i,j,nz) + btm_src(i,j)) + & (ea(i,j,nz) + sink(i,nz)) * tr(i,j,nz-1)) endif ; enddo - if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j)>0.5) then + if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then btm_reservoir(i,j) = btm_reservoir(i,j) + (sink(i,nz+1)*tr(i,j,nz)) * GV%H_to_RZ endif ; enddo ; endif - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo else !$OMP do do j=js,je - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then h_tr = h_old(i,j,1) + h_neglect b_denom_1 = h_tr + ea(i,j,1) b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) d1(i) = h_tr * b1(i) tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = eb(i,j,k-1) * b1(i) h_tr = h_old(i,j,k) + h_neglect b_denom_1 = h_tr + d1(i) * ea(i,j,k) @@ -199,7 +199,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & d1(i) = b_denom_1 * b1(i) tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + ea(i,j,k) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = eb(i,j,nz-1) * b1(i) h_tr = h_old(i,j,nz) + h_neglect b_denom_1 = h_tr + d1(i)*ea(i,j,nz) @@ -207,7 +207,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * (( h_tr * tr(i,j,nz) + btm_src(i,j)) + & ea(i,j,nz) * tr(i,j,nz-1)) endif ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo @@ -345,14 +345,14 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & enddo ! Now solve the tridiagonal equation for the tracer concentrations. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then b_denom_1 = h_minus_dsink(i,1) + ent(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + ent(i,j,2)) d1(i) = b_denom_1 * b1(i) h_tr = h_old(i,j,1) + h_neglect tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = ent(i,j,K) * b1(i) b_denom_1 = h_minus_dsink(i,k) + d1(i) * (ent(i,j,K) + sink(i,K)) + & h_neglect @@ -362,7 +362,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + & (ent(i,j,K) + sink(i,K)) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = ent(i,j,nz) * b1(i) b_denom_1 = h_minus_dsink(i,nz) + d1(i) * (ent(i,j,nz) + sink(i,nz)) + & h_neglect @@ -371,25 +371,25 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * ((h_tr * tr(i,j,nz) + btm_src(i,j)) + & (ent(i,j,nz) + sink(i,nz)) * tr(i,j,nz-1)) endif ; enddo - if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j)>0.5) then + if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then btm_reservoir(i,j) = btm_reservoir(i,j) + (sink(i,nz+1)*tr(i,j,nz)) * GV%H_to_RZ endif ; enddo ; endif - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo else !$OMP do do j=js,je - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then h_tr = h_old(i,j,1) + h_neglect b_denom_1 = h_tr + ent(i,j,1) b1(i) = 1.0 / (b_denom_1 + ent(i,j,2)) d1(i) = h_tr * b1(i) tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = ent(i,j,K) * b1(i) h_tr = h_old(i,j,k) + h_neglect b_denom_1 = h_tr + d1(i) * ent(i,j,K) @@ -397,7 +397,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & d1(i) = b_denom_1 * b1(i) tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + ent(i,j,K) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = ent(i,j,nz) * b1(i) h_tr = h_old(i,j,nz) + h_neglect b_denom_1 = h_tr + d1(i)*ent(i,j,nz) @@ -405,7 +405,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * (( h_tr * tr(i,j,nz) + btm_src(i,j)) + & ent(i,j,nz) * tr(i,j,nz-1)) endif ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 850480e3e6..3d2b322759 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -728,7 +728,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! mixed and buffer layer corresponds to, such that: ! GV%Rlay(max_kRho-1) < Rml_max <= GV%Rlay(max_kRho) !$OMP parallel do default(shared) private(k_min,k_max,k_test) - do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.5) then + do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.0) then if ((Rml_max(i,j) > GV%Rlay(nz)) .or. (nkmb+1 > nz)) then ; max_kRho(i,j) = nz+1 elseif ((Rml_max(i,j) <= GV%Rlay(nkmb+1)) .or. (nkmb+2 > nz)) then ; max_kRho(i,j) = nkmb+1 else @@ -756,7 +756,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP parallel default(shared) private(ns,tmp,itmp) !$OMP do do j=js-1,je+1 - do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then + do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then if (h(i,j,k) > h_exclude) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k @@ -764,7 +764,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & h_srt(i,ns,j) = h(i,j,k) endif endif ; enddo ; enddo - do k=nkmb+1,PEmax_kRho ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then + do k=nkmb+1,PEmax_kRho ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then if ((k<=k_end_srt(i,j)) .and. (h(i,j,k) > h_exclude)) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k @@ -812,7 +812,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, & !$OMP wt_b,left_set,right_set,h_supply_frac_R, & !$OMP h_supply_frac_L) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.5) then + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then ! Set up the pairings for fluxes through the zonal faces. do k=1,num_srt(i,j) ; h_demand_L(k) = 0.0 ; h_used_L(k) = 0.0 ; enddo @@ -965,7 +965,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, & !$OMP wt_b,left_set,right_set,h_supply_frac_R, & !$OMP h_supply_frac_L) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.5) then + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! Set up the pairings for fluxes through the meridional faces. do k=1,num_srt(i,j) ; h_demand_L(k) = 0.0 ; h_used_L(k) = 0.0 ; enddo @@ -1120,7 +1120,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb,Tr_La, & !$OMP Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R,h_L,h_R, & !$OMP Tr_flux,Tr_adj_vert,wt_a,vol) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.5) then + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then ! Determine the fluxes through the zonal faces. ! Find the acceptable range of tracer concentration around this face. @@ -1260,7 +1260,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, & !$OMP Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, & !$OMP h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.5) then + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! Determine the fluxes through the meridional faces. ! Find the acceptable range of tracer concentration around this face. @@ -1377,7 +1377,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP tr_flux_conv,Tr_flux_3d,k0a_Lv,Tr_adj_vert_L,& !$OMP deep_wt_Rv,k0a_Rv,Tr_adj_vert_R) & !$OMP private(kLa,kLb,kRa,kRb,wt_b,wt_a) - do i=is,ie ; do J=js-1,je ; if (G%mask2dCv(i,J) > 0.5) then + do i=is,ie ; do J=js-1,je ; if (G%mask2dCv(i,J) > 0.0) then do k=1,nPv(i,J) kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k) if (deep_wt_Lv(J)%p(i,k) >= 1.0) then @@ -1402,7 +1402,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif ; enddo ; enddo !$OMP parallel do default(none) shared(PEmax_kRho,is,ie,js,je,G,h,Tr,tr_flux_conv,m) do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (h(i,j,k) > 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (h(i,j,k) > 0.0)) then Tr(m)%t(i,j,k) = Tr(m)%t(i,j,k) + tr_flux_conv(i,j,k) / & (h(i,j,k)*G%areaT(i,j)) tr_flux_conv(i,j,k) = 0.0 diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index f85623bbd1..4f5a3ea873 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -270,7 +270,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! Set surface conditions do m=1,1 - if (CS%remaining_source_time>0.0) then + if (CS%remaining_source_time > 0.0) then do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 1.0 enddo ; enddo ; enddo diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 5913251b14..a809e77a4c 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -352,7 +352,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, exp((year-CS%tracer_start_year(m)) * CS%sfc_growth_rate(m)) endif do k=1,CS%nkml ; do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = sfc_val else CS%tr(i,j,k,m) = CS%land_val(m) From e7eae07cd64a00205742c6bc94bafcb8dce5a1dc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 Apr 2022 10:38:15 -0400 Subject: [PATCH 07/10] +Document or eliminate undocumented interfaces Address undocumented interfaces by adding explicit interfaces to replaces one level of the pass-throughs or eliminated them. Specifically - Eliminated global_field_sum() from MOM_domains, as it is no longer used anywhere in the MOM6 code or drivers. At the config_src/infra level, the pass-through calls to mpp_global_sum are commented out in case there are other versions of the MOM6 code that still use global_field_sum. - Added explicit interfaces to horizontal_interp_init() and time_interp_extern_init() in the config_src/infra rather that leaving them as undocumented pass-throughs to the FMS code. - Added the explicit subroutine stdout_if_root() to MOM_io.F90 to replace an undocumented pass-through to the FMS stdout function. - Added comments describing the publicly visible encoding parameters ind_flux, ind_alpha, and ind_csurf that are a part of the coupler_types module. - Removed the unnecessary or commented-out public declarations for post_data_1d_k, vert_fill_TS, and legacy_diabatic. All answers are bitwise identical, but there are some minor changes to the names of subroutines offered at the config_src/infra level to permit the documentation of these interfaces without running afoul of some bugs with certain versions of the gnu compiler. --- .../drivers/mct_cap/mom_surface_forcing_mct.F90 | 1 - .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 1 - config_src/infra/FMS1/MOM_domain_infra.F90 | 6 +++--- config_src/infra/FMS1/MOM_interp_infra.F90 | 14 ++++++++++++-- config_src/infra/FMS2/MOM_domain_infra.F90 | 6 +++--- config_src/infra/FMS2/MOM_interp_infra.F90 | 15 ++++++++++++--- src/framework/MOM_coupler_types.F90 | 4 +++- src/framework/MOM_diag_mediator.F90 | 1 - src/framework/MOM_domains.F90 | 7 ++----- src/framework/MOM_horizontal_regridding.F90 | 9 +++++---- src/framework/MOM_interpolate.F90 | 6 +++--- src/framework/MOM_io.F90 | 6 +++++- .../lateral/MOM_thickness_diffuse.F90 | 1 - .../vertical/MOM_diabatic_driver.F90 | 1 - 14 files changed, 48 insertions(+), 30 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 a8a3ea0c69..ebb63865b7 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -9,7 +9,6 @@ module MOM_surface_forcing_mct use MOM_diag_mediator, only : diag_ctrl use MOM_diag_mediator, only : safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg 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 d04ecf10e4..3c03009d43 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -10,7 +10,6 @@ module MOM_surface_forcing_nuopc use MOM_diag_mediator, only : diag_ctrl use MOM_diag_mediator, only : safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 7eff4597f3..f28c36b9d2 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -27,7 +27,7 @@ module MOM_domain_infra use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get ! This subroutine is not in MOM6/src but may be required by legacy drivers -use mpp_domains_mod, only : global_field_sum => mpp_global_sum +! use mpp_domains_mod, only : global_field_sum => mpp_global_sum ! The `group_pass_type` fields are never accessed, so we keep it as an FMS type use mpp_domains_mod, only : group_pass_type => mpp_group_update_type @@ -45,13 +45,13 @@ module MOM_domain_infra public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! These are encoding constant parmeters. +! These are encoding constant parmeters with self-explanatory names. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR public :: CORNER, CENTER, NORTH_FACE, EAST_FACE ! These are no longer used by MOM6 because the reproducing sum works so well, but they are ! still referenced by some of the non-GFDL couplers. -public :: global_field_sum, BITWISE_EXACT_SUM +! public :: global_field_sum, BITWISE_EXACT_SUM !> Do a halo update on an array interface pass_var diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index 774f6a67d2..224e26a051 100644 --- a/config_src/infra/FMS1/MOM_interp_infra.F90 +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -14,8 +14,8 @@ module MOM_interp_infra implicit none ; private -public :: horiz_interp_type, horiz_interp_init -public :: time_interp_extern, init_extern_field, time_interp_external_init +public :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights @@ -39,6 +39,16 @@ module MOM_interp_infra contains +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + !> perform horizontal interpolation of a 2d field using pre-computed weights !! source and destination coordinates are 2d subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index 5f8d5fb20b..a19f022cc7 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -27,7 +27,7 @@ module MOM_domain_infra use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get ! This subroutine is not in MOM6/src but may be required by legacy drivers -use mpp_domains_mod, only : global_field_sum => mpp_global_sum +! use mpp_domains_mod, only : global_field_sum => mpp_global_sum ! The `group_pass_type` fields are never accessed, so we keep it as an FMS type use mpp_domains_mod, only : group_pass_type => mpp_group_update_type @@ -45,13 +45,13 @@ module MOM_domain_infra public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! These are encoding constant parmeters. +! These are encoding constant parmeters with self-explanatory names. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR public :: CORNER, CENTER, NORTH_FACE, EAST_FACE ! These are no longer used by MOM6 because the reproducing sum works so well, but they are ! still referenced by some of the non-GFDL couplers. -public :: global_field_sum, BITWISE_EXACT_SUM +! public :: global_field_sum, BITWISE_EXACT_SUM !> Do a halo update on an array interface pass_var diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index b02beca313..c29459aad1 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -14,8 +14,8 @@ module MOM_interp_infra implicit none ; private -public :: horiz_interp_type, horiz_interp_init -public :: time_interp_extern, init_extern_field, time_interp_external_init +public :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights @@ -39,6 +39,16 @@ module MOM_interp_infra contains +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + !> perform horizontal interpolation of a 2d field using pre-computed weights !! source and destination coordinates are 2d subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & @@ -61,7 +71,6 @@ subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, end subroutine horiz_interp_from_weights_field2d - !> perform horizontal interpolation of a 3d field using pre-computed weights !! source and destination coordinates are 2d subroutine horiz_interp_from_weights_field3d(Interp, data_in, data_out, verbose, mask_in, mask_out, & diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index 73304f7fe8..f87b409694 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -19,8 +19,10 @@ module MOM_coupler_types public :: set_coupler_type_data, extract_coupler_type_data, coupler_type_redistribute_data public :: coupler_type_copy_data, coupler_type_increment_data, coupler_type_rescale_data public :: atmos_ocn_coupler_flux, coupler_type_data_override -public :: ind_flux, ind_alpha, ind_csurf public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type +! These are encoding constant parameters that indicate whether a flux, solubility or +! surface ocean concentration are being set or accessed with an inquiry. +public :: ind_flux, ind_alpha, ind_csurf !> This is the interface to spawn one coupler_bc_type into another. interface coupler_type_spawn diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 1ed89ec47e..7fb2580906 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -41,7 +41,6 @@ module MOM_diag_mediator public set_axes_info, post_data, register_diag_field, time_type public post_product_u, post_product_sum_u, post_product_v, post_product_sum_v public set_masks_for_axes -public post_data_1d_k public safe_alloc_ptr, safe_alloc_alloc public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled public diag_mediator_init, diag_mediator_end, set_diag_mediator_grid diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 00c42727e1..a97ae52e35 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -10,14 +10,14 @@ module MOM_domains use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain use MOM_domain_infra, only : get_domain_extent, get_domain_components, same_domain use MOM_domain_infra, only : compute_block_extent, get_global_shape -use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges, global_field_sum +use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges use MOM_domain_infra, only : pass_var_start, pass_var_complete use MOM_domain_infra, only : pass_vector_start, pass_vector_complete use MOM_domain_infra, only : create_group_pass, do_group_pass use MOM_domain_infra, only : start_group_pass, complete_group_pass use MOM_domain_infra, only : rescale_comp_data, global_field, redistribute_array, broadcast_domain use MOM_domain_infra, only : MOM_thread_affinity_set, set_MOM_thread_affinity -use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR use MOM_domain_infra, only : CORNER, CENTER, NORTH_FACE, EAST_FACE use MOM_domain_infra, only : To_East, To_West, To_North, To_South, To_All, Omit_Corners use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL @@ -54,9 +54,6 @@ module MOM_domains public :: CORNER, CENTER, NORTH_FACE, EAST_FACE !> These encoding constants indicate communication patterns. In practice they can be added. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners -! These are no longer used by MOM6 because the reproducing sum works so well, but they are -! still referenced by some of the non-GFDL couplers. -public :: global_field_sum, BITWISE_EXACT_SUM contains diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 5a125d5abd..3bc16a6aff 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -12,8 +12,9 @@ module MOM_horizontal_regridding use MOM_error_handler, only : MOM_get_verbosity use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_interpolate, only : time_interp_external, horiz_interp_init -use MOM_interpolate, only : build_horiz_interp_weights, run_horiz_interp, horiz_interp_type +use MOM_interpolate, only : time_interp_external +use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights +use MOM_interp_infra, only : horiz_interp_type, horizontal_interp_init use MOM_interp_infra, only : axistype, get_external_field_info, get_axis_data use MOM_time_manager, only : time_type use MOM_io, only : axis_info, get_axis_info, get_var_axes_info, MOM_read_data @@ -410,7 +411,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, allocate(tr_in(is:ie,js:je), source=0.0) allocate(mask_in(is:ie,js:je), source=0.0) else - call horiz_interp_init() + call horizontal_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 allocate(x_in(id,jdp), y_in(id,jdp)) @@ -708,7 +709,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t else jdp = jd endif - call horiz_interp_init() + call horizontal_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 allocate(x_in(id,jdp), y_in(id,jdp)) diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index 4a931d0bf3..8f20bf73fe 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -6,15 +6,15 @@ module MOM_interpolate use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_error_handler, only : MOM_error, FATAL use MOM_interp_infra, only : time_interp_extern, init_external_field=>init_extern_field -use MOM_interp_infra, only : time_interp_external_init, get_external_field_info -use MOM_interp_infra, only : horiz_interp_type, horiz_interp_init +use MOM_interp_infra, only : time_interp_external_init=>time_interp_extern_init +use MOM_interp_infra, only : horiz_interp_type, get_external_field_info use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights use MOM_time_manager, only : time_type implicit none ; private public :: time_interp_external, init_external_field, time_interp_external_init, get_external_field_info -public :: horiz_interp_type, horiz_interp_init, run_horiz_interp, build_horiz_interp_weights +public :: horiz_interp_type, run_horiz_interp, build_horiz_interp_weights !> Read a field based on model time, and rotate to the model domain. interface time_interp_external diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 8928d2e56b..61ed23b268 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -21,7 +21,6 @@ module MOM_io use MOM_io_infra, only : get_file_times, axistype, get_axis_data, get_filename_suffix use MOM_io_infra, only : write_field, write_metadata, write_version use MOM_io_infra, only : MOM_namelist_file, check_namelist_error, io_infra_init, io_infra_end -use MOM_io_infra, only : stdout_if_root use MOM_io_infra, only : APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE use MOM_io_infra, only : READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_io_infra, only : CENTER, CORNER, NORTH_FACE, EAST_FACE @@ -587,6 +586,11 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim end subroutine reopen_file +!> Return the index of sdtout if called from the root PE, or 0 for other PEs. +integer function stdout_if_root() + stdout_if_root = 0 + if (is_root_PE()) stdout_if_root = stdout +end function stdout_if_root !> This function determines how many time levels a variable has in a file. function num_timelevels(filename, varname, min_dims) result(n_time) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 55e4593dc4..7304688d32 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -25,7 +25,6 @@ module MOM_thickness_diffuse #include public thickness_diffuse, thickness_diffuse_init, thickness_diffuse_end -! public vert_fill_TS public thickness_diffuse_get_KH ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7b180f1d65..cc240dfa95 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -81,7 +81,6 @@ module MOM_diabatic_driver public extract_diabatic_member public adiabatic public adiabatic_driver_init -! public legacy_diabatic ! 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 From e56562047fea39fcb6c90f48dcd22108dac0f3e7 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 11 Apr 2022 16:02:12 -0400 Subject: [PATCH 08/10] Removal of non-standard extensions This patch removes any non-standard compiler extensions from the source and replaces them with equivalent standard statements. Specifically, this allows the code to be compiled with GCC using the -std=f2018 flag. None of these changes impact GFDL testing, since all extensions were supported by GNU, Intel, and PGI, but at least offer some greater assurance that the code will compile and behave more predicably on as-yet untested platforms. The specific changes are outlined below: * `loc() == 0` tests have been replaced with `associated()` where appropriate. (If field is not a pointer then it was removed, since using loc() was already a very bad idea.) * the `dfloat()` type conversion was replaced with `real()`. For consistency with existing MOM code, the `kind` remains unspecified. Technically this could represent an answer change, but was only applied to nz, which is always a very small integer. * `abort()` is an extension, and is replaced with the compliant (and admittedly platform-dependent) `error stop` statement. --- src/core/MOM_open_boundary.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 3 --- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- src/user/ISOMIP_initialization.F90 | 4 ++-- src/user/dumbbell_initialization.F90 | 2 +- src/user/seamount_initialization.F90 | 2 +- 6 files changed, 6 insertions(+), 9 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index bda0b2df38..39ceccaf49 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1741,7 +1741,7 @@ subroutine parse_segment_param_real(segment_str, var, param_value, debug ) endif enddo if (m==0) then - call abort() + error stop endif ! Process first word which will start with the fieldname diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ef71d9286c..22c0ddf8de 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -234,9 +234,6 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! This value is roughly (pi / (the age of the universe) )^2. absurdly_small_freq2 = 1e-34*US%T_to_s**2 - if (loc(CS)==0) call MOM_error(FATAL, & - "calculate_diagnostic_fields: Module must be initialized before used.") - if (.not. CS%initialized) call MOM_error(FATAL, & "calculate_diagnostic_fields: Module must be initialized before used.") diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 3d2b322759..f3d77d2ef3 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -174,7 +174,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (.not. associated(CS)) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "register_tracer must be called before tracer_hordiff.") - if (LOC(Reg)==0) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + if (.not. associated(Reg)) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "register_tracer must be called before tracer_hordiff.") if (Reg%ntr == 0 .or. (CS%KhTr <= 0.0 .and. .not. VarMix%use_variable_mixing)) return diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 7386a008e6..b0601e2165 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -232,7 +232,7 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) enddo ; enddo case default @@ -574,7 +574,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * (depth_tot(i,j) / dfloat(nz)) + h(i,j,:) = GV%Z_to_H * (depth_tot(i,j) / real(nz)) enddo ; enddo case default diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 20beebc67f..2bc2533de5 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -198,7 +198,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) enddo ; enddo end select diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 3dba7bfe59..a112737248 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -181,7 +181,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) enddo ; enddo end select From f926696d333666a65fd7e2a6c7d06e1fcd735973 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 Apr 2022 06:46:00 -0400 Subject: [PATCH 09/10] +Remove append_substring Removed the unused and unnecessary function append_substring. All answers are bitwise identical, but an unused public interface is being eliminated. --- src/framework/MOM_string_functions.F90 | 29 -------------------------- 1 file changed, 29 deletions(-) diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index ddc1b41290..5c04a77b7d 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -17,7 +17,6 @@ module MOM_string_functions public extract_real public remove_spaces public slasher -public append_substring contains @@ -419,34 +418,6 @@ function slasher(dir) endif end function slasher -!> append a string (substring) to another string (string_in) and return the -!! concatenated string (string_out) -function append_substring(string_in, substring) result(string_out) - character(len=*), intent(in) :: string_in !< input string - character(len=*), intent(in) :: substring !< string to append string_in - ! local - character(len=1024) :: string_out - character(len=1024) :: string_joined - integer :: string_in_length - integer :: substring_length - - string_out = '' - string_joined = '' - string_in_length = 0 - substring_length = 0 - - string_in_length = len_trim(string_in) - substring_length = len_trim(substring) - - if (string_in_length > 0) then - if (substring_length > 0) then - string_joined = trim(string_in)//trim(substring) - string_out(1:len_trim(string_joined)) = trim(string_joined) - endif - endif - -end function append_substring - !> \namespace mom_string_functions !! !! By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013. From 3b3fda01d63d0f3b07b3904a4cbff3136a49d88d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Apr 2022 15:45:52 -0400 Subject: [PATCH 10/10] Fix non-standard white space (#109) * Fix non-standard white space Made widespread corrections to indentation and other white space issues to conform to the MOM6 standards, as documented in the white space section of the MOM6 style guide, at https://github.com/mom-ocean/MOM6/wiki/Code-style-guide. - MOM6 code uses a 2-point indent scheme. - There should be a space around all assignment (" = ") operators. - The names of optional arguments do not use whitespace, to differentiate them from assignments. - There is a space around the semicolons for stacked enddo statements. After this change, greping for '^ [a-zA-Z]', '^ [a-zA-Z]' or '^ [a-zA-Z]' does not find any lines in the MOM6 src or config_src/infra code. All answers and output are bitwise identical. --- .../infra/FMS1/MOM_diag_manager_infra.F90 | 60 +-- config_src/infra/FMS1/MOM_domain_infra.F90 | 16 +- .../infra/FMS2/MOM_diag_manager_infra.F90 | 60 +-- config_src/infra/FMS2/MOM_domain_infra.F90 | 16 +- src/ALE/MOM_ALE.F90 | 2 +- src/ALE/MOM_hybgen_remap.F90 | 2 +- src/ALE/MOM_remapping.F90 | 2 +- src/core/MOM.F90 | 2 +- src/core/MOM_barotropic.F90 | 2 +- src/core/MOM_dynamics_split_RK2.F90 | 4 +- src/core/MOM_dynamics_unsplit.F90 | 4 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 4 +- src/core/MOM_forcing_type.F90 | 14 +- src/core/MOM_open_boundary.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/equation_of_state/MOM_EOS_NEMO.F90 | 4 +- src/equation_of_state/MOM_TFreeze.F90 | 2 +- src/framework/MOM_diag_mediator.F90 | 2 +- src/framework/MOM_domains.F90 | 2 +- src/framework/MOM_horizontal_regridding.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 20 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 198 ++++----- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 342 +++++++------- .../MOM_state_initialization.F90 | 28 +- src/ocean_data_assim/MOM_oda_incupd.F90 | 420 +++++++++--------- .../vertical/MOM_ALE_sponge.F90 | 6 +- .../vertical/MOM_CVMix_conv.F90 | 2 +- .../vertical/MOM_CVMix_ddiff.F90 | 2 +- .../vertical/MOM_CVMix_shear.F90 | 4 +- .../vertical/MOM_bkgnd_mixing.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 2 +- src/tracer/MOM_OCMIP2_CFC.F90 | 10 +- src/tracer/MOM_generic_tracer.F90 | 192 ++++---- src/tracer/MOM_lateral_boundary_diffusion.F90 | 12 +- src/tracer/MOM_neutral_diffusion.F90 | 4 +- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- src/user/BFB_surface_forcing.F90 | 2 +- src/user/dumbbell_surface_forcing.F90 | 2 +- 38 files changed, 726 insertions(+), 728 deletions(-) diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 18c80cf24c..69d82b7d85 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -72,36 +72,36 @@ module MOM_diag_manager_infra !> Initialize a diagnostic axis integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & & direction, edges, set_name, coarsen, null_axis) - character(len=*), intent(in) :: name !< The name of this axis - real, dimension(:), intent(in) :: data !< The array of coordinate values - character(len=*), intent(in) :: units !< The units for the axis data - character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) - character(len=*), & - optional, intent(in) :: long_name !< The long name of this axis - type(MOM_domain_type), & - optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - integer, optional, intent(in) :: position !< This indicates the relative position of this - !! axis. The default is CENTER, but EAST and NORTH - !! are common options. - integer, optional, intent(in) :: direction !< This indicates the direction along which this - !! axis increases: 1 for upward, -1 for downward, or - !! 0 for non-vertical axes (the default) - integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that - !! describes the edges of this axis - character(len=*), & - optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 - !! by default. - logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis - !! id for use with scalars. - - integer :: coarsening ! The degree of grid coarsening - - if (present(null_axis)) then ; if (null_axis) then - ! Return the special null axis id for scalars - MOM_diag_axis_init = null_axis_id - return - endif ; endif + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif if (present(MOM_domain)) then coarsening = 1 ; if (present(coarsen)) coarsening = coarsen diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index f28c36b9d2..249453f42b 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -1906,14 +1906,14 @@ end subroutine get_simple_array_j_ind !> Invert the contents of a 1-d array subroutine invert(array) - integer, dimension(:), intent(inout) :: array !< The 1-d array to invert - integer :: i, ni, swap - ni = size(array) - do i=1,ni - swap = array(i) - array(i) = array(ni+1-i) - array(ni+1-i) = swap - enddo + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo end subroutine invert !> Returns the global shape of h-point arrays diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index 18c80cf24c..69d82b7d85 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -72,36 +72,36 @@ module MOM_diag_manager_infra !> Initialize a diagnostic axis integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & & direction, edges, set_name, coarsen, null_axis) - character(len=*), intent(in) :: name !< The name of this axis - real, dimension(:), intent(in) :: data !< The array of coordinate values - character(len=*), intent(in) :: units !< The units for the axis data - character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) - character(len=*), & - optional, intent(in) :: long_name !< The long name of this axis - type(MOM_domain_type), & - optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - integer, optional, intent(in) :: position !< This indicates the relative position of this - !! axis. The default is CENTER, but EAST and NORTH - !! are common options. - integer, optional, intent(in) :: direction !< This indicates the direction along which this - !! axis increases: 1 for upward, -1 for downward, or - !! 0 for non-vertical axes (the default) - integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that - !! describes the edges of this axis - character(len=*), & - optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 - !! by default. - logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis - !! id for use with scalars. - - integer :: coarsening ! The degree of grid coarsening - - if (present(null_axis)) then ; if (null_axis) then - ! Return the special null axis id for scalars - MOM_diag_axis_init = null_axis_id - return - endif ; endif + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif if (present(MOM_domain)) then coarsening = 1 ; if (present(coarsen)) coarsening = coarsen diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index a19f022cc7..d845d7317b 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -1905,14 +1905,14 @@ end subroutine get_simple_array_j_ind !> Invert the contents of a 1-d array subroutine invert(array) - integer, dimension(:), intent(inout) :: array !< The 1-d array to invert - integer :: i, ni, swap - ni = size(array) - do i=1,ni - swap = array(i) - array(i) = array(ni+1-i) - array(ni+1-i) = swap - enddo + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo end subroutine invert !> Returns the global shape of h-point arrays diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 876c2c684b..e5666a5157 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -334,7 +334,7 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) 'm', conversion=GV%H_to_m, v_extensive=.true.) cs%id_vert_remap_h_tendency = register_diag_field('ocean_model','vert_remap_h_tendency',diag%axestl,time, & 'Layer thicknesses tendency due to ALE regridding and remapping', & - 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) + 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive=.true.) end subroutine ALE_register_diags diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90 index 539c992283..59974afad1 100644 --- a/src/ALE/MOM_hybgen_remap.F90 +++ b/src/ALE/MOM_hybgen_remap.F90 @@ -192,7 +192,7 @@ subroutine hybgen_ppm_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(s(k,i)-s(k-1,i)) * & ( h01_h112(K) - h23_h122(K) ) & + (dp(k)*as(k-1)*h23_h122(K) - dp(k-1)*as(k)*h01_h112(K)) ) - ar(k-1) = al(k) + ar(k-1) = al(k) enddo !k ar(nk-1) = s(nk,i) ! last layer PCM al(nk) = s(nk,i) ! last layer PCM diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index ebe0f81743..4146237e21 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -205,7 +205,7 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value !! calculations in the same units as h0 [H] - logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for + logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for !! cells in the source grid where this is true. ! Local variables diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0703e45696..db08802cca 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1908,7 +1908,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If False, T/S are registered for advection. "//& "This is intended only to be used in offline tracer mode "//& "and is by default false in that case.", & - do_not_log = .true., default=.true. ) + do_not_log=.true., default=.true.) if (present(offline_tracer_mode)) then ! Only read this parameter in enabled modes call get_param(param_file, "MOM", "OFFLINE_TRACER_MODE", CS%offline_tracer_mode, & "If true, barotropic and baroclinic dynamics, thermodynamics "//& diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 3b5c812ba1..d4e365f688 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -3053,7 +3053,7 @@ end subroutine apply_velocity_OBCs !! 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) - type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. + 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 diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index b01c462480..21c9702ca0 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1342,10 +1342,10 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + x_cell_method='sum', v_extensive=.true.) if (GV%Boussinesq) then CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & 'Barotropic SSH tendency due to dynamics', trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 085b4e02c3..e23a2c4ca1 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -694,10 +694,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & 'Effective U Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 91aaca508e..8c855d3aec 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -656,10 +656,10 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag 'Meridional Pressure Force Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 6de46f7738..9fe449e726 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -265,15 +265,15 @@ module MOM_forcing_type !! ice needs to be accumulated, and the rigidity explicitly !! reset to zero at the driver level when appropriate. real, pointer, dimension(:,:) :: & - ustk0 => NULL(), & !< Surface Stokes drift, zonal [m s-1] - vstk0 => NULL() !< Surface Stokes drift, meridional [m s-1] + ustk0 => NULL(), & !< Surface Stokes drift, zonal [m s-1] + vstk0 => NULL() !< Surface Stokes drift, meridional [m s-1] real, pointer, dimension(:) :: & - stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad m-1] + stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad m-1] real, pointer, dimension(:,:,:) :: & - ustkb => NULL(), & !< Stokes Drift spectrum, zonal [m s-1] + ustkb => NULL(), & !< Stokes Drift spectrum, zonal [m s-1] !! Horizontal - u points !! 3rd dimension - wavenumber - vstkb => NULL() !< Stokes Drift spectrum, meridional [m s-1] + vstkb => NULL() !< Stokes Drift spectrum, meridional [m s-1] !! Horizontal - v points !! 3rd dimension - wavenumber @@ -1503,14 +1503,14 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_field_name='ave_evs', cmor_standard_name='water_evaporation_flux_area_averaged', & cmor_long_name='Evaporation Where Ice Free Ocean over Sea Area Averaged') - handles%id_lprec_ga = register_scalar_field('ocean_model', 'lprec_ga', Time, diag,& + handles%id_lprec_ga = register_scalar_field('ocean_model', 'lprec_ga', Time, diag,& long_name='Area integrated liquid precip into ocean', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='rainfall_flux_area_averaged', & cmor_field_name='ave_pr', cmor_standard_name='rainfall_flux_area_averaged', & cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea Area Averaged') - handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag, & + handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag, & long_name='Area integrated frozen precip into ocean', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='snowfall_flux_area_averaged', & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 39ceccaf49..971fd7e8ee 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1630,7 +1630,7 @@ end subroutine parse_segment_data_str !> Parse all the OBC_SEGMENT_%%%_DATA strings again !! to see which need tracer reservoirs (all pes need to know). - subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) +subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle logical, intent(in) :: use_temperature !< If true, T and S are used diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 22c0ddf8de..9c22ab5eb5 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -452,7 +452,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! area mean SSS if (CS%id_sosga > 0) then do j=js,je ; do i=is,ie - surface_field(i,j) = tv%S(i,j,1) + surface_field(i,j) = tv%S(i,j,1) enddo ; enddo sosga = global_area_mean(surface_field, G) call post_data(CS%id_sosga, sosga, CS%diag) diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index 68488881bb..b8c2ec2601 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -259,7 +259,7 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re rho(j) = ( zn + zr0 ) ! density endif - enddo + enddo end subroutine calculate_density_array_nemo !> For a given thermodynamic state, calculate the derivatives of density with conservative @@ -391,7 +391,7 @@ subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) - enddo + enddo end subroutine calculate_compress_nemo end module MOM_EOS_NEMO diff --git a/src/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90 index 50233cae60..f0b22c8f4e 100644 --- a/src/equation_of_state/MOM_TFreeze.F90 +++ b/src/equation_of_state/MOM_TFreeze.F90 @@ -165,7 +165,7 @@ subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) if (S(j) < -1.0e-10) cycle !Can we assume safely that this is a missing value? T_Fr(j) = gsw_ct_freezing_exact(zs,zp,saturation_fraction) - enddo + enddo end subroutine calculate_TFreeze_teos10_array diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 7fb2580906..be8ccd774b 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -2234,7 +2234,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time ! Register the native diagnostic if (associated(axes_d2)) then - active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index a97ae52e35..47ac43df06 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -182,7 +182,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ "The number of OpenMP threads that MOM6 will use.", & !$ default = 1, layoutParam=.true.) !$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & - !$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) + !$ "If True, use hyper-threading.", default=.false., layoutParam=.true.) !$ call set_MOM_thread_affinity(ocean_nthreads, ocean_omp_hyper_thread) !$ endif # endif diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 3bc16a6aff..1889c59469 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -249,7 +249,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, call MOM_error(FATAL,"MOM_initialize: "// & "fill is true and good is false after fill_miss, how did this happen? ") endif - enddo ; enddo + enddo ; enddo end subroutine fill_miss_2d diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5db9198a22..5b63851b8e 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -327,8 +327,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ISS => CS%ISS if (CS%data_override_shelf_fluxes .and. CS%active_shelf_dynamics) then - call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux, CS%Time, & - scale=US%kg_m2s_to_RZ_T) + call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux, CS%Time, & + scale=US%kg_m2s_to_RZ_T) endif if (CS%rotate_index) then @@ -741,13 +741,13 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) scale=US%RZ_to_kg_m2) endif - call change_thickness_using_precip(CS, ISS, G, US, fluxes,US%s_to_T*time_step, Time) + call change_thickness_using_precip(CS, ISS, G, US, fluxes, US%s_to_T*time_step, Time) - if (CS%debug) then - call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, scale=US%Z_to_m) - call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using surf acc", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) - endif + if (CS%debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using surf acc", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) + endif endif @@ -2136,8 +2136,8 @@ subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf, data_override_shelf_ endif if (present(data_override_shelf_fluxes)) then - data_override_shelf_fluxes=.false. - if (CS%active_shelf_dynamics) data_override_shelf_fluxes = CS%data_override_shelf_fluxes + data_override_shelf_fluxes=.false. + if (CS%active_shelf_dynamics) data_override_shelf_fluxes = CS%data_override_shelf_fluxes endif end subroutine ice_shelf_query diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index e1ecd45347..979517d227 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -540,31 +540,31 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif ! 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) - - ! initialize ice-stiffness AGlen - call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) - call pass_var(CS%AGlen_visc, G%domain) - - !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) - - !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%bed_elev, G%domain,CENTER) - call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) - endif + 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) + + ! initialize ice-stiffness AGlen + call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) + call pass_var(CS%AGlen_visc, G%domain) + + !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) + + !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%bed_elev, G%domain,CENTER) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + endif ! Register diagnostics. CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesB1, Time, & 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) @@ -628,7 +628,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) enddo enddo - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) end subroutine initialize_diagnostic_fields !> This function returns the global maximum advective timestep that can be taken based on the current @@ -691,58 +691,58 @@ 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) - CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step - if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. - - if (coupled_GL) then - 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(:,:)) - endif - - - if (update_ice_vel) then - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) - endif - -! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) - - if (update_ice_vel) 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) - 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(:,:) - 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(:,:) - 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) - 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(:,:) - call post_data(CS%id_visc_shelf, ice_visc,CS%diag) - endif - if (CS%id_taub > 0) then - basal_tr(:,:) = CS%basal_traction(:,:)*G%IareaT(:,:) - call post_data(CS%id_taub, basal_tr,CS%diag) - endif + call ice_shelf_advect(CS, ISS, G, time_step, Time) + CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. + + if (coupled_GL) then + 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(:,:)) + endif + + + if (update_ice_vel) then + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + endif + +! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) + + if (update_ice_vel) 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) + 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(:,:) + 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(:,:) + 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) + 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(:,:) + call post_data(CS%id_visc_shelf, ice_visc, CS%diag) + endif + if (CS%id_taub > 0) then + basal_tr(:,:) = CS%basal_traction(:,:)*G%IareaT(:,:) + call post_data(CS%id_taub, basal_tr, CS%diag) + endif !! - if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) - if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) - if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask,CS%u_face_mask_bdry,CS%diag) - if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask,CS%v_face_mask_bdry,CS%diag) -! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) + if (CS%id_u_mask > 0) call post_data(CS%id_u_mask, CS%umask, CS%diag) + if (CS%id_v_mask > 0) call post_data(CS%id_v_mask, CS%vmask, CS%diag) + if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask, CS%u_face_mask_bdry, CS%diag) + if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask, CS%v_face_mask_bdry, CS%diag) +! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask, CS%tmask, CS%diag) - call disable_averaging(CS%diag) + call disable_averaging(CS%diag) - CS%elapsed_velocity_time = 0.0 - endif + CS%elapsed_velocity_time = 0.0 + endif end subroutine update_ice_shelf @@ -836,7 +836,7 @@ end subroutine ice_shelf_advect !>This subroutine computes u- and v-velocities of the ice shelf iterating on non-linear ice viscosity !subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) - subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, iters, Time) +subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, iters, Time) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -948,7 +948,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! 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) + 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, & @@ -1001,8 +1001,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! 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) +! 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 u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 @@ -1371,7 +1371,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H enddo call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - if (conv_flag == 0) then + if (conv_flag == 0) then iters = CS%cg_max_iterations endif @@ -1859,8 +1859,8 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo enddo - call pass_var(S, G%domain) - allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + 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 @@ -2011,7 +2011,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo enddo - deallocate(Phi) + deallocate(Phi) end subroutine calc_shelf_driving_stress subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) @@ -2616,11 +2616,10 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) n_g = CS%n_glen; eps_min = CS%eps_glen_min CS%ice_visc(:,:)=1e22 ! Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) - do j=jsc,jec - do i=isc,iec + do j=jsc,jec ; do i=isc,iec - if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then - Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) + if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then + Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) do iq=1,2 ; do jq=1,2 @@ -2643,13 +2642,12 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) 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 -! CS%ice_visc(i,j) =1e15*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + enddo ; enddo +! CS%ice_visc(i,j) =1e15*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging + 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)) - endif - enddo - enddo + endif + enddo ; enddo deallocate(Phi) end subroutine calc_shelf_visc @@ -2863,16 +2861,16 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) do qpoint=1,4 - if (J>1) then + if (J>1) then a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) - else - a= G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) - endif - if (I>1) then + else + a = G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) + endif + if (I>1) then d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) - else + else d = G%dyCu(I,j) !* xquad(qpoint) - endif + endif ! a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) ! d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index d3202a9f2a..7bd3b45b2a 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -277,120 +277,120 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b thickness_bdry_val, hmask, h_shelf, G,& US, PF ) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces - - real, dimension(SZIB_(G),SZJ_(G)), & - intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through - !! C-grid u faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces - - real, dimension(SZI_(G),SZJB_(G)), & - intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through - !! C-grid v faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - !! boundary vertices [L T-1 ~> m s-1]. - - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_shelf !< Ice-shelf thickness [Z ~> m] - 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 - - character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. - integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed - real :: input_thick ! The input ice shelf thickness [Z ~> m] - real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] - real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises - - - call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) - - call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "WESTLON", westlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "SOUTHLAT", southlat, fail_if_missing=.true.) - - call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & - "inflow ice velocity at upstream boundary", & - units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) !### This conversion factor is wrong? - call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & - "flux thickness at upstream boundary", & - units="m", default=1000., scale=US%m_to_Z) - call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & - "maximum position of no-flow condition in along-flow direction", & - units="km", default=0.) - - call MOM_mesg(mdl//": setting boundary") - - isd = G%isd ; ied = G%ied - jsd = G%jsd ; jed = G%jed - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - gjsd = G%Domain%njglobal ; gisd = G%Domain%niglobal - gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo - giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc - - !---------b.c.s based on geopositions ----------------- - do j=jsc,jec+1 - do i=isc-1,iec+1 - ! upstream boundary - set either dirichlet or flux condition - - if (G%geoLonBu(i,j) == westlon) then - 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_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution - endif - - - ! side boundaries: no flow - if (G%geoLatBu(i,j-1) == southlat) then !bot boundary - if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then - v_face_mask_bdry(i,j+1) = 0. - u_face_mask_bdry(i,j) = 3. - u_bdry_val(i,j) = 0. - v_bdry_val(i,j) = 0. - else - v_face_mask_bdry(i,j+1) = 1. - u_face_mask_bdry(i,j) = 3. - u_bdry_val(i,j) = 0. - v_bdry_val(i,j) = 0. - endif - elseif (G%geoLatBu(i,j-1) == southlat+lenlat) then !top boundary - if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then - v_face_mask_bdry(i,j-1) = 0. - u_face_mask_bdry(i,j-1) = 3. - else - v_face_mask_bdry(i,j-1) = 3. - u_face_mask_bdry(i,j-1) = 3. - endif - endif - - ! downstream boundary - CFBC - if (G%geoLonBu(i,j) == westlon+lenlon) then - u_face_mask_bdry(i-1,j) = 2.0 - endif - - enddo - enddo + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces + + real, dimension(SZIB_(G),SZJ_(G)), & + intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through + !! C-grid u faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces + + real, dimension(SZI_(G),SZJB_(G)), & + intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through + !! C-grid v faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + !! boundary vertices [L T-1 ~> m s-1]. + + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< Ice-shelf thickness [Z ~> m] + 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 + + character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. + integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed + real :: input_thick ! The input ice shelf thickness [Z ~> m] + real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] + real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises + + + call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) + + call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) + + call get_param(PF, mdl, "WESTLON", westlon, fail_if_missing=.true.) + + call get_param(PF, mdl, "SOUTHLAT", southlat, fail_if_missing=.true.) + + call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & + "inflow ice velocity at upstream boundary", & + units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) !### This conversion factor is wrong? + call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & + "flux thickness at upstream boundary", & + units="m", default=1000., scale=US%m_to_Z) + call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & + "maximum position of no-flow condition in along-flow direction", & + units="km", default=0.) + + call MOM_mesg(mdl//": setting boundary") + + isd = G%isd ; ied = G%ied + jsd = G%jsd ; jed = G%jed + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + gjsd = G%Domain%njglobal ; gisd = G%Domain%niglobal + gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo + giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc + + !---------b.c.s based on geopositions ----------------- + do j=jsc,jec+1 + do i=isc-1,iec+1 + ! upstream boundary - set either dirichlet or flux condition + + if (G%geoLonBu(i,j) == westlon) then + 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_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution + endif + + + ! side boundaries: no flow + if (G%geoLatBu(i,j-1) == southlat) then !bot boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j+1) = 0. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + else + v_face_mask_bdry(i,j+1) = 1. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + endif + elseif (G%geoLatBu(i,j-1) == southlat+lenlat) then !top boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j-1) = 0. + u_face_mask_bdry(i,j-1) = 3. + else + v_face_mask_bdry(i,j-1) = 3. + u_face_mask_bdry(i,j-1) = 3. + endif + endif + + ! downstream boundary - CFBC + if (G%geoLonBu(i,j) == westlon+lenlon) then + u_face_mask_bdry(i-1,j) = 2.0 + endif + + enddo + enddo end subroutine initialize_ice_shelf_boundary_channel @@ -400,10 +400,10 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: bed_elev !< The bed elevation [Z ~> m]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: float_cond !< An array indicating where the ice @@ -471,33 +471,33 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask u_bdry_val, v_bdry_val, umask, vmask, h_bdry_val, thickness_bdry_val, & hmask, h_shelf, G, US, PF ) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: umask !< A mask for ice shelf velocity [nondim] - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: vmask !< A mask for ice shelf velocity [nondim] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf [nondim] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: h_shelf !< Ice-shelf thickness [Z ~> m] - 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 + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: umask !< A mask for ice shelf velocity [nondim] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: vmask !< A mask for ice shelf velocity [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< Ice-shelf thickness [Z ~> m] + 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 character(len=200) :: filename, bc_file, inputdir, icethick_file ! Strings for file/path character(len=200) :: ufcmskbdry_varname, vfcmskbdry_varname, & @@ -562,10 +562,10 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask do j=jsc,jec do i=isc,iec - if (hmask(i,j) == 3.) then - thickness_bdry_val(i,j) = h_shelf(i,j) - h_bdry_val(i,j) = h_shelf(i,j) - endif + if (hmask(i,j) == 3.) then + thickness_bdry_val(i,j) = h_shelf(i,j) + h_bdry_val(i,j) = h_shelf(i,j) + endif enddo enddo @@ -574,8 +574,8 @@ end subroutine initialize_ice_shelf_boundary_from_file !> Initialize ice basal friction subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: C_basal_friction !< Ice-stream basal friction + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: C_basal_friction !< Ice-stream basal friction 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 @@ -595,19 +595,19 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) call get_param(PF, mdl, "BASAL_FRICTION_COEFF", C_friction, & "Coefficient in sliding law.", units="Pa (m s-1)^(n_basal_fric)", default=5.e10) - C_basal_friction(:,:) = C_friction + C_basal_friction(:,:) = C_friction elseif (trim(config)=="FILE") then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") - call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) - call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & - "The file from which basal friction coefficients are read.", & - default="ice_basal_friction.nc") - filename = trim(inputdir)//trim(C_friction_file) - call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) + call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & + "The file from which basal friction coefficients are read.", & + default="ice_basal_friction.nc") + filename = trim(inputdir)//trim(C_friction_file) + call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) - call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & + call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & "The variable to use in basal traction.", & default="tau_b_beta") @@ -623,8 +623,8 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) !> Initialize ice basal friction subroutine initialize_ice_AGlen(AGlen, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen 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 @@ -644,19 +644,19 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) call get_param(PF, mdl, "A_GLEN", A_Glen, & "Ice-stiffness parameter.", units="Pa-3 s-1", default=2.261e-25) - AGlen(:,:) = A_Glen + AGlen(:,:) = A_Glen elseif (trim(config)=="FILE") then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") - call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) - call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & + call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & "The file from which the ice-stiffness is read.", & default="ice_AGlen.nc") - filename = trim(inputdir)//trim(AGlen_file) - call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) - call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & + filename = trim(inputdir)//trim(AGlen_file) + call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) + call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & "The variable to use as ice-stiffness.", & default="A_GLEN") diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ee3052f166..0aeba26e17 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1947,7 +1947,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t "The name of the inverse damping rate variable in "//& "SPONGE_UV_DAMPING_FILE for the velocities.", default=Idamp_var) endif - call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) + call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log=.true.) !### NEW_SPONGES should be obsoleted properly, rather than merely deprecated, at which ! point only the else branch of the new_sponge_param block would be retained. @@ -2000,18 +2000,18 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t call MOM_read_vector(filename, Idamp_u_var,Idamp_v_var,Idamp_u(:,:),Idamp_v(:,:), G%Domain, scale=US%T_to_s) else - ! call MOM_error(FATAL, "Must provide SPONGE_IDAMP_U_var and SPONGE_IDAMP_V_var") - call pass_var(Idamp,G%Domain) - do j=G%jsc,G%jec - do i=G%iscB,G%iecB - Idamp_u(I,j) = 0.5*(Idamp(i,j)+Idamp(i+1,j)) - enddo - enddo - do j=G%jscB,G%jecB - do i=G%isc,G%iec - Idamp_v(i,J) = 0.5*(Idamp(i,j)+Idamp(i,j+1)) - enddo - enddo + ! call MOM_error(FATAL, "Must provide SPONGE_IDAMP_U_var and SPONGE_IDAMP_V_var") + call pass_var(Idamp,G%Domain) + do j=G%jsc,G%jec + do i=G%iscB,G%iecB + Idamp_u(I,j) = 0.5*(Idamp(i,j)+Idamp(i+1,j)) + enddo + enddo + do j=G%jscB,G%jecB + do i=G%isc,G%iec + Idamp_v(i,J) = 0.5*(Idamp(i,j)+Idamp(i,j+1)) + enddo + enddo endif endif @@ -2255,7 +2255,7 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p "The name of the meridional vel. inc. variable in "//& "ODA_INCUPD_FILE.", default="v_inc") -! call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) +! call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log=.true.) ! Read in incremental update for tracers filename = trim(inputdir)//trim(inc_file) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index 5f38fa15d0..80c313e488 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -201,13 +201,13 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re ! get number of timestep for full update if (nhours_incupd == 0) then - CS%nstep_incupd = 1 !! direct insertion + CS%nstep_incupd = 1 !! direct insertion else - CS%nstep_incupd = floor( nhours_incupd * 3600. / dt_therm + 0.001 ) - 1 + CS%nstep_incupd = floor( nhours_incupd * 3600. / dt_therm + 0.001 ) - 1 endif write(mesg,'(i12)') CS%nstep_incupd if (is_root_pe()) & - call MOM_error(NOTE,"initialize_oda_incupd: Number of Timestep of inc. update:"//& + call MOM_error(NOTE,"initialize_oda_incupd: Number of Timestep of inc. update:"//& trim(mesg)) ! number of inc. update already done, CS%ncount, either from restart or set to 0.0 @@ -219,14 +219,14 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re endif write(mesg,'(f4.1)') CS%ncount if (is_root_pe()) & - call MOM_error(NOTE,"initialize_oda_incupd: Inc. update already done:"//& + call MOM_error(NOTE,"initialize_oda_incupd: Inc. update already done:"//& trim(mesg)) ! get the vertical grid (h_obs) of the increments CS%nz_data = nz_data allocate(CS%Ref_h%p(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=0.0) do j=G%jsc,G%jec; do i=G%isc,G%iec ; do k=1,CS%nz_data - CS%Ref_h%p(i,j,k) = data_h(i,j,k) + CS%Ref_h%p(i,j,k) = data_h(i,j,k) enddo; enddo ; enddo !### Doing a halo update here on CS%Ref_h%p would avoid needing halo updates each timestep. @@ -263,7 +263,7 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) CS%Inc(CS%fldno)%nz_data = CS%nz_data allocate(CS%Inc(CS%fldno)%p(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=0.0) do k=1,CS%nz_data ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%Inc(CS%fldno)%p(i,j,k) = sp_val(i,j,k) + CS%Inc(CS%fldno)%p(i,j,k) = sp_val(i,j,k) enddo ; enddo ; enddo end subroutine set_up_oda_incupd_field @@ -374,122 +374,122 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) ! remap t,s (on h_init) to h_obs to get increment tmp_val1(:) = 0.0 do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) == 1) then + if (G%mask2dT(i,j) == 1) then + ! account for the different SSH + sum_h1 = 0.0 + sum_h2 = 0.0 + do k=1,nz + sum_h1 = sum_h1+h(i,j,k) + enddo + + do k=1,nz_data + sum_h2 = sum_h2+h_obs(i,j,k) + enddo + do k=1,nz_data + tmp_h(k)=(sum_h1/sum_h2)*h_obs(i,j,k) + enddo + ! get temperature + do k=1,nz + tmp_val1(k) = tv%T(i,j,k) + enddo + ! remap tracer on h_obs + call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & + nz_data, tmp_h(1:nz_data), tmp_val2, & + h_neglect, h_neglect_edge) + ! get increment from full field on h_obs + do k=1,nz_data + CS%Inc(1)%p(i,j,k) = CS%Inc(1)%p(i,j,k) - tmp_val2(k) + enddo + + ! get salinity + do k=1,nz + tmp_val1(k) = tv%S(i,j,k) + enddo + ! remap tracer on h_obs + call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & + nz_data, tmp_h(1:nz_data), tmp_val2, & + h_neglect, h_neglect_edge) + ! get increment from full field on h_obs + do k=1,nz_data + CS%Inc(2)%p(i,j,k) = CS%Inc(2)%p(i,j,k) - tmp_val2(k) + enddo + endif + enddo ; enddo + + ! remap u to h_obs to get increment + if (CS%uv_inc) then + call pass_var(h, G%Domain) + + hu(:) = 0.0 + do j=js,je ; do i=isB,ieB + if (G%mask2dCu(i,j) == 1) then + ! get u-velocity + do k=1,nz + tmp_val1(k) = u(i,j,k) + ! get the h and h_obs at u points + hu(k) = 0.5*( h(i,j,k)+ h(i+1,j,k)) + enddo + do k=1,nz_data + hu_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i+1,j,k)) + enddo ! account for the different SSH sum_h1 = 0.0 - sum_h2 = 0.0 do k=1,nz - sum_h1 = sum_h1+h(i,j,k) + sum_h1 = sum_h1+hu(k) enddo - + sum_h2 = 0.0 do k=1,nz_data - sum_h2 = sum_h2+h_obs(i,j,k) + sum_h2 = sum_h2+hu_obs(k) enddo do k=1,nz_data - tmp_h(k)=(sum_h1/sum_h2)*h_obs(i,j,k) + hu_obs(k)=(sum_h1/sum_h2)*hu_obs(k) enddo - ! get temperature - do k=1,nz - tmp_val1(k) = tv%T(i,j,k) - enddo - ! remap tracer on h_obs - call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & - nz_data, tmp_h(1:nz_data), tmp_val2, & + ! remap model u on hu_obs + call remapping_core_h(CS%remap_cs, nz, hu(1:nz), tmp_val1, & + nz_data, hu_obs(1:nz_data), tmp_val2, & h_neglect, h_neglect_edge) ! get increment from full field on h_obs do k=1,nz_data - CS%Inc(1)%p(i,j,k) = CS%Inc(1)%p(i,j,k) - tmp_val2(k) + CS%Inc_u%p(i,j,k) = CS%Inc_u%p(i,j,k) - tmp_val2(k) enddo - - ! get salinity + endif + enddo ; enddo + + ! remap v to h_obs to get increment + hv(:) = 0.0; + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,j) == 1) then + ! get v-velocity do k=1,nz - tmp_val1(k) = tv%S(i,j,k) + tmp_val1(k) = v(i,j,k) + ! get the h and h_obs at v points + hv(k) = 0.5*(h(i,j,k)+h(i,j+1,k)) enddo - ! remap tracer on h_obs - call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & - nz_data, tmp_h(1:nz_data), tmp_val2, & + do k=1,nz_data + hv_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i,j+1,k)) + enddo + ! account for the different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1+hv(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2+hv_obs(k) + enddo + do k=1,nz_data + hv_obs(k)=(sum_h1/sum_h2)*hv_obs(k) + enddo + ! remap model v on hv_obs + call remapping_core_h(CS%remap_cs, nz, hv(1:nz), tmp_val1, & + nz_data, hv_obs(1:nz_data), tmp_val2, & h_neglect, h_neglect_edge) ! get increment from full field on h_obs do k=1,nz_data - CS%Inc(2)%p(i,j,k) = CS%Inc(2)%p(i,j,k) - tmp_val2(k) + CS%Inc_v%p(i,j,k) = CS%Inc_v%p(i,j,k) - tmp_val2(k) enddo - endif - enddo; enddo - - ! remap u to h_obs to get increment - if (CS%uv_inc) then - call pass_var(h, G%Domain) - - hu(:) = 0.0 - do j=js,je ; do i=isB,ieB - if (G%mask2dCu(i,j) == 1) then - ! get u-velocity - do k=1,nz - tmp_val1(k) = u(i,j,k) - ! get the h and h_obs at u points - hu(k) = 0.5*( h(i,j,k)+ h(i+1,j,k)) - enddo - do k=1,nz_data - hu_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i+1,j,k)) - enddo - ! account for the different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1+hu(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2+hu_obs(k) - enddo - do k=1,nz_data - hu_obs(k)=(sum_h1/sum_h2)*hu_obs(k) - enddo - ! remap model u on hu_obs - call remapping_core_h(CS%remap_cs, nz, hu(1:nz), tmp_val1, & - nz_data, hu_obs(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) - ! get increment from full field on h_obs - do k=1,nz_data - CS%Inc_u%p(i,j,k) = CS%Inc_u%p(i,j,k) - tmp_val2(k) - enddo - endif - enddo; enddo - - ! remap v to h_obs to get increment - hv(:) = 0.0; - do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,j) == 1) then - ! get v-velocity - do k=1,nz - tmp_val1(k) = v(i,j,k) - ! get the h and h_obs at v points - hv(k) = 0.5*(h(i,j,k)+h(i,j+1,k)) - enddo - do k=1,nz_data - hv_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i,j+1,k)) - enddo - ! account for the different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1+hv(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2+hv_obs(k) - enddo - do k=1,nz_data - hv_obs(k)=(sum_h1/sum_h2)*hv_obs(k) - enddo - ! remap model v on hv_obs - call remapping_core_h(CS%remap_cs, nz, hv(1:nz), tmp_val1, & - nz_data, hv_obs(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) - ! get increment from full field on h_obs - do k=1,nz_data - CS%Inc_v%p(i,j,k) = CS%Inc_v%p(i,j,k) - tmp_val2(k) - enddo - endif - enddo; enddo + endif + enddo ; enddo endif ! uv_inc call pass_var(CS%Inc(1)%p, G%Domain) @@ -603,118 +603,118 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) tmp_h(k) = ( sum_h1 / sum_h2 ) * h_obs(i,j,k) enddo if (G%mask2dT(i,j) == 1) then - ! get temperature increment - do k=1,nz_data - tmp_val2(k) = CS%Inc(1)%p(i,j,k) - enddo - ! remap increment profile on model h - call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data), tmp_val2, & - nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) - do k=1,nz - ! add increment to tracer on model h - tv%T(i,j,k) = tv%T(i,j,k) + inc_wt * tmp_val1(k) - tmp_t(i,j,k) = tmp_val1(k) ! store T increment for diagnostics - enddo - - ! get salinity increment - do k=1,nz_data - tmp_val2(k) = CS%Inc(2)%p(i,j,k) - enddo - ! remap increment profile on model h - call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data),tmp_val2,& - nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) - ! add increment to tracer on model h - do k=1,nz - tv%S(i,j,k) = tv%S(i,j,k) + inc_wt * tmp_val1(k) - tmp_s(i,j,k) = tmp_val1(k) ! store S increment for diagnostics - ! bound salinity values ! check if it is correct to do that or if it hides - ! other problems ... - tv%S(i,j,k) = max(0.0 , tv%S(i,j,k)) - enddo + ! get temperature increment + do k=1,nz_data + tmp_val2(k) = CS%Inc(1)%p(i,j,k) + enddo + ! remap increment profile on model h + call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data), tmp_val2, & + nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) + do k=1,nz + ! add increment to tracer on model h + tv%T(i,j,k) = tv%T(i,j,k) + inc_wt * tmp_val1(k) + tmp_t(i,j,k) = tmp_val1(k) ! store T increment for diagnostics + enddo + + ! get salinity increment + do k=1,nz_data + tmp_val2(k) = CS%Inc(2)%p(i,j,k) + enddo + ! remap increment profile on model h + call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data),tmp_val2,& + nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) + ! add increment to tracer on model h + do k=1,nz + tv%S(i,j,k) = tv%S(i,j,k) + inc_wt * tmp_val1(k) + tmp_s(i,j,k) = tmp_val1(k) ! store S increment for diagnostics + ! bound salinity values ! check if it is correct to do that or if it hides + ! other problems ... + tv%S(i,j,k) = max(0.0 , tv%S(i,j,k)) + enddo endif - enddo; enddo + enddo ; enddo ! add u and v increments if (CS%uv_inc) then - call pass_var(h,G%Domain) ! to ensure reproducibility - - ! add increments to u - hu(:) = 0.0 - tmp_u(:,:,:) = 0.0 ! diagnostics - do j=js,je ; do i=isB,ieB - if (G%mask2dCu(i,j) == 1) then - do k=1,nz_data - ! get u increment - tmp_val2(k) = CS%Inc_u%p(i,j,k) - ! get the h and h_obs at u points - hu_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i+1,j,k) ) - enddo - do k=1,nz - hu(k) = 0.5 * ( h(i,j,k) + h(i+1,j,k) ) - enddo - ! account for different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1 + hu(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2 + hu_obs(k) - enddo - do k=1,nz_data - hu_obs(k)=( sum_h1 / sum_h2 ) * hu_obs(k) - enddo - ! remap increment profile on hu - call remapping_core_h(CS%remap_cs, nz_data, hu_obs(1:nz_data), tmp_val2, & - nz, hu(1:nz), tmp_val1, h_neglect, h_neglect_edge) - ! add increment to u-velocity on hu - do k=1,nz - u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) - ! store increment for diagnostics - tmp_u(i,j,k) = tmp_val1(k) - enddo - endif - enddo; enddo - - ! add increments to v - hv(:) = 0.0 - tmp_v(:,:,:) = 0.0 ! diagnostics - do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,j) == 1) then - ! get v increment - do k=1,nz_data - tmp_val2(k) = CS%Inc_v%p(i,j,k) - ! get the h and h_obs at v points - hv_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i,j+1,k) ) - enddo - do k=1,nz - hv(k) = 0.5 * (h(i,j,k) + h(i,j+1,k) ) - enddo - ! account for different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1 + hv(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2 + hv_obs(k) - enddo - do k=1,nz_data - hv_obs(k)=( sum_h1 / sum_h2 ) * hv_obs(k) - enddo - ! remap increment profile on hv - call remapping_core_h(CS%remap_cs, nz_data, hv_obs(1:nz_data), tmp_val2, & - nz, hv(1:nz), tmp_val1, h_neglect, h_neglect_edge) - ! add increment to v-velocity on hv - do k=1,nz - v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) - ! store increment for diagnostics - tmp_v(i,j,k) = tmp_val1(k) - enddo - endif - enddo; enddo + call pass_var(h,G%Domain) ! to ensure reproducibility + + ! add increments to u + hu(:) = 0.0 + tmp_u(:,:,:) = 0.0 ! diagnostics + do j=js,je ; do i=isB,ieB + if (G%mask2dCu(i,j) == 1) then + do k=1,nz_data + ! get u increment + tmp_val2(k) = CS%Inc_u%p(i,j,k) + ! get the h and h_obs at u points + hu_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i+1,j,k) ) + enddo + do k=1,nz + hu(k) = 0.5 * ( h(i,j,k) + h(i+1,j,k) ) + enddo + ! account for different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1 + hu(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2 + hu_obs(k) + enddo + do k=1,nz_data + hu_obs(k) = ( sum_h1 / sum_h2 ) * hu_obs(k) + enddo + ! remap increment profile on hu + call remapping_core_h(CS%remap_cs, nz_data, hu_obs(1:nz_data), tmp_val2, & + nz, hu(1:nz), tmp_val1, h_neglect, h_neglect_edge) + ! add increment to u-velocity on hu + do k=1,nz + u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) + ! store increment for diagnostics + tmp_u(i,j,k) = tmp_val1(k) + enddo + endif + enddo ; enddo + + ! add increments to v + hv(:) = 0.0 + tmp_v(:,:,:) = 0.0 ! diagnostics + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,j) == 1) then + ! get v increment + do k=1,nz_data + tmp_val2(k) = CS%Inc_v%p(i,j,k) + ! get the h and h_obs at v points + hv_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i,j+1,k) ) + enddo + do k=1,nz + hv(k) = 0.5 * (h(i,j,k) + h(i,j+1,k) ) + enddo + ! account for different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1 + hv(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2 + hv_obs(k) + enddo + do k=1,nz_data + hv_obs(k)=( sum_h1 / sum_h2 ) * hv_obs(k) + enddo + ! remap increment profile on hv + call remapping_core_h(CS%remap_cs, nz_data, hv_obs(1:nz_data), tmp_val2, & + nz, hv(1:nz), tmp_val1, h_neglect, h_neglect_edge) + ! add increment to v-velocity on hv + do k=1,nz + v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) + ! store increment for diagnostics + tmp_v(i,j,k) = tmp_val1(k) + enddo + endif + enddo ; enddo endif ! uv_inc diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 446cdb8b45..10b46f7e7d 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -275,15 +275,15 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! u points CS%num_col_u = 0 ; if (present(Iresttime_u_in)) then - Iresttime_u(:,:) = Iresttime_u_in(:,:) + Iresttime_u(:,:) = Iresttime_u_in(:,:) else do j=G%jsc,G%jec ; do I=G%iscB,G%iecB Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) enddo ; enddo endif do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & - CS%num_col_u = CS%num_col_u + 1 + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & + CS%num_col_u = CS%num_col_u + 1 enddo ; enddo if (CS%num_col_u > 0) then diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 7371ba7009..58d6e3417a 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -293,7 +293,7 @@ end subroutine calculate_CVMix_conv logical function CVMix_conv_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_conv_is_used diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index f1ac4c926a..aca84f59e2 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -274,7 +274,7 @@ end subroutine compute_ddiff_coeffs logical function CVMix_ddiff_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_ddiff_is_used diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index eed99ceb3f..db98e063d8 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -326,9 +326,9 @@ logical function CVMix_shear_is_used(param_file) ! Local variables logical :: LMD94, PP81 call get_param(param_file, mdl, "USE_LMD94", LMD94, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) call get_param(param_file, mdl, "Use_PP81", PP81, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) CVMix_shear_is_used = (LMD94 .or. PP81) end function CVMix_shear_is_used diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index c3ee727573..fb218a7d67 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -523,7 +523,7 @@ end subroutine calculate_bkgnd_mixing logical function CVMix_bkgnd_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMix_BACKGROUND", CVMix_bkgnd_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_bkgnd_is_used diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index cc240dfa95..8f82dce3c9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3370,7 +3370,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_heat_tend = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency', diag%axesTL, Time, & 'Boundary forcing heat tendency', & - 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive = .true.) + 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) if (CS%id_boundary_forcing_heat_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 28a9501d51..2928a0c718 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -288,14 +288,14 @@ subroutine flux_init_OCMIP2_CFC(CS, verbosity) ! These calls obtain the indices for the CFC11 and CFC12 flux coupling. They ! can safely be called multiple times. ind_flux(1) = atmos_ocn_coupler_flux('cfc_11_flux', & - flux_type = 'air_sea_gas_flux', implementation='ocmip2', & + flux_type='air_sea_gas_flux', implementation='ocmip2', & param=(/ 9.36e-07, 9.7561e-06 /), & - ice_restart_file = default_ice_restart_file, & - ocean_restart_file = default_ocean_restart_file, & - caller = "register_OCMIP2_CFC", verbosity=verbosity) + ice_restart_file=default_ice_restart_file, & + ocean_restart_file=default_ocean_restart_file, & + caller="register_OCMIP2_CFC", verbosity=verbosity) ind_flux(2) = atmos_ocn_coupler_flux('cfc_12_flux', & flux_type='air_sea_gas_flux', implementation='ocmip2', & - param = (/ 9.36e-07, 9.7561e-06 /), & + param=(/ 9.36e-07, 9.7561e-06 /), & ice_restart_file=default_ice_restart_file, & ocean_restart_file=default_ocean_restart_file, & caller="register_OCMIP2_CFC", verbosity=verbosity) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 5e8632f1ca..65947fc64c 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -129,8 +129,8 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Register all the generic tracers used and create the list of them. !This can be called by ALL PE's. No array fields allocated. if (.not. g_registered) then - call generic_tracer_register() - g_registered = .true. + call generic_tracer_register() + g_registered = .true. endif @@ -188,29 +188,29 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) g_tracer=>CS%g_tracer_list do - call g_tracer_get_alias(g_tracer,g_tracer_name) - - call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) - call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) - call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) - - !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? - tr_ptr => tr_field(:,:,:,1) - ! Register prognastic tracer for horizontal advection, diffusion, and restarts. - if (g_tracer_is_prog(g_tracer)) then - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & - name=g_tracer_name, longname=longname, units=units, & - registry_diags=.false., & !### CHANGE TO TRUE? - restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) - else - call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & - restart_CS, longname=longname, units=units) - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next + call g_tracer_get_alias(g_tracer,g_tracer_name) + + call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) + call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) + call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) + + !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? + tr_ptr => tr_field(:,:,:,1) + ! Register prognastic tracer for horizontal advection, diffusion, and restarts. + if (g_tracer_is_prog(g_tracer)) then + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=g_tracer_name, longname=longname, units=units, & + registry_diags=.false., & !### CHANGE TO TRUE? + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + else + call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & + restart_CS, longname=longname, units=units) + endif + + !traverse the linked list till hit NULL + call g_tracer_get_next(g_tracer, g_tracer_next) + if (.NOT. associated(g_tracer_next)) exit + g_tracer=>g_tracer_next enddo @@ -281,70 +281,70 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(tr_ptr, g_tracer_name, CS%restart_CSp))) then - if (g_tracer%requires_src_info ) then - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initializing generic tracer "//trim(g_tracer_name)//& - " using MOM_initialize_tracer_from_Z ") - - call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & - src_file = g_tracer%src_file, & - src_var_nam = g_tracer%src_var_name, & - src_var_unit_conversion = g_tracer%src_var_unit_conversion,& - src_var_record = g_tracer%src_var_record, & - src_var_gridspec = g_tracer%src_var_gridspec ) - - !Check/apply the bounds for each g_tracer - do k=1,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min - !Jasmin does not want to apply the maximum for now - !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max - endif - enddo ; enddo ; enddo - - !jgj: Reset CASED to 0 below K=1 - if ( (trim(g_tracer_name) == 'cased') .or. (trim(g_tracer_name) == 'ca13csed') ) then - do k=2,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - tr_ptr(i,j,k) = 0.0 - endif - enddo ; enddo ; enddo - endif - elseif(.not. g_tracer%requires_restart) then + if (g_tracer%requires_src_info ) then + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "initializing generic tracer "//trim(g_tracer_name)//& + " using MOM_initialize_tracer_from_Z ") + + call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & + src_file = g_tracer%src_file, & + src_var_nam = g_tracer%src_var_name, & + src_var_unit_conversion = g_tracer%src_var_unit_conversion,& + src_var_record = g_tracer%src_var_record, & + src_var_gridspec = g_tracer%src_var_gridspec ) + + !Check/apply the bounds for each g_tracer + do k=1,nk ; do j=jsc,jec ; do i=isc,iec + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then + if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min + !Jasmin does not want to apply the maximum for now + !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max + endif + enddo ; enddo ; enddo + + !jgj: Reset CASED to 0 below K=1 + if ( (trim(g_tracer_name) == 'cased') .or. (trim(g_tracer_name) == 'ca13csed') ) then + do k=2,nk ; do j=jsc,jec ; do i=isc,iec + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then + tr_ptr(i,j,k) = 0.0 + endif + enddo ; enddo ; enddo + endif + elseif(.not. g_tracer%requires_restart) then !Do nothing for this tracer, it is initialized by the tracer package call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& "skip initialization of generic tracer "//trim(g_tracer_name)) - else !Do it old way if the tracer is not registered to start from a specific source file. + else !Do it old way if the tracer is not registered to start from a specific source file. !This path should be deprecated if all generic tracers are required to start from specified sources. - if (len_trim(CS%IC_file) > 0) then - ! Read the tracer concentrations from a netcdf file. - if (.not.file_exists(CS%IC_file)) call MOM_error(FATAL, & - "initialize_MOM_Generic_tracer: Unable to open "//CS%IC_file) - if (CS%Z_IC_file) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G, GV, US) - if (.not.OK) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G, GV, US) - if (.not.OK) call MOM_error(FATAL,"initialize_MOM_Generic_tracer: "//& - "Unable to read "//trim(g_tracer_name)//" from "//& - trim(CS%IC_file)//".") + if (len_trim(CS%IC_file) > 0) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%IC_file)) call MOM_error(FATAL, & + "initialize_MOM_Generic_tracer: Unable to open "//CS%IC_file) + if (CS%Z_IC_file) then + OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G, GV, US) + if (.not.OK) then + OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G, GV, US) + if (.not.OK) call MOM_error(FATAL,"initialize_MOM_Generic_tracer: "//& + "Unable to read "//trim(g_tracer_name)//" from "//& + trim(CS%IC_file)//".") + endif + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "initialized generic tracer "//trim(g_tracer_name)//& + " using Generic Tracer File on Z: "//CS%IC_file) + else + ! native grid + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "Using Generic Tracer IC file on native grid "//trim(CS%IC_file)//& + " for tracer "//trim(g_tracer_name)) + call MOM_read_data(CS%IC_file, trim(g_tracer_name), tr_ptr, G%Domain) endif - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initialized generic tracer "//trim(g_tracer_name)//& - " using Generic Tracer File on Z: "//CS%IC_file) else - ! native grid - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "Using Generic Tracer IC file on native grid "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - call MOM_read_data(CS%IC_file, trim(g_tracer_name), tr_ptr, G%Domain) + call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& + "check Generic Tracer IC filename "//trim(CS%IC_file)//& + " for tracer "//trim(g_tracer_name)) endif - else - call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& - "check Generic Tracer IC filename "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - endif - endif + endif endif !traverse the linked list till hit NULL @@ -459,21 +459,21 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! g_tracer=>CS%g_tracer_list do - if (_ALLOCATED(g_tracer%trunoff)) then - call g_tracer_get_alias(g_tracer,g_tracer_name) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) - !nnz: Why is fluxes%river = 0? - runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & - US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) - stf_array = stf_array + runoff_tracer_flux_array - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next + if (_ALLOCATED(g_tracer%trunoff)) then + call g_tracer_get_alias(g_tracer,g_tracer_name) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) + !nnz: Why is fluxes%river = 0? + runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & + US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) + stf_array = stf_array + runoff_tracer_flux_array + endif + + !traverse the linked list till hit NULL + call g_tracer_get_next(g_tracer, g_tracer_next) + if (.NOT. associated(g_tracer_next)) exit + g_tracer => g_tracer_next enddo diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 7296640560..8efb341ec3 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -126,7 +126,7 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction = .false., check_remapping = .false., answers_2018 = .false.) + check_reconstruction=.false., check_remapping=.false., answers_2018=.false.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "LBD_DEBUG", CS%debug, & "If true, write out verbose debugging data in the LBD module.", & @@ -382,9 +382,9 @@ subroutine unique(val, n, val_unique, val_max) max_val = MAXVAL(val) i = 0 do while (min_valmin_val) - tmp(i) = min_val + i = i+1 + min_val = MINVAL(val, mask=val>min_val) + tmp(i) = min_val enddo ii = i if (limit) then @@ -745,8 +745,8 @@ logical function near_boundary_unit_tests( verbose ) allocate(CS) ! fill required fields in CS CS%linear=.false. - call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation = .true. ,& - check_reconstruction = .true., check_remapping = .true.) + call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true. ,& + check_reconstruction=.true., check_remapping=.true.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) CS%H_subroundoff = 1.0E-20 CS%debug=.false. diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 08361ba9af..7f1f39bbc0 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -167,11 +167,11 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, & "If true, only applies neutral diffusion in the ocean interior."//& "That is, the algorithm will exclude the surface and bottom"//& - "boundary layers.", default = .false.) + "boundary layers.", default=.false.) call get_param(param_file, mdl, "NDIFF_USE_UNMASKED_TRANSPORT_BUG", CS%use_unmasked_transport_bug, & "If true, use an older form for the accumulation of neutral-diffusion "//& "transports that were unmasked, as used prior to Jan 2018. This is not "//& - "recommended.", default = .false.) + "recommended.", default=.false.) ! Initialize and configure remapping if ( .not.CS%continuous_reconstruction ) then diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index f3d77d2ef3..5012cc4d66 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1498,7 +1498,7 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_File, mdl, "RECALC_NEUTRAL_SURF", CS%recalc_neutral_surf, & "If true, then recalculate the neutral surfaces if the \n"//& "diffusive CFL is exceeded. If false, assume that the \n"//& - "positions of the surfaces do not change \n", default = .false.) + "positions of the surfaces do not change \n", default=.false.) CS%ML_KhTR_scale = 1.0 if (CS%Diffuse_ML_interior) then call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 6214f2d095..64fb31f68d 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -223,7 +223,7 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) 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.) + "given by FLUXCONST.", default=.false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 8c980edc8e..54985e35fc 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -228,7 +228,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) 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.) + "given by FLUXCONST.", default=.false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//&